Excel 2013 VBA - Testing cell Contents

I need a macro that
1. moves the active cell up one row from the current location.
Tests for cell contents. Does this cell contain any numbers or alphanumeric characters?
if yes
     - move down one row and type the word "Filled"
     - move one column to the right
     - message box "Do you want to continue Yes/No"
          if yes, go to step 1 above
          if no exit procedure.

If no,
move down one row
Move one column to the right.
Exit procedure
Who is Participating?
Rgonzo1971Connect With a Mentor Commented:

pls try
Sub macro()

res = vbNo
If Selection.Offset(-1) Like "*[A-Za-z0-9]*" Then
    Selection.Value = "Filled"
    Selection.Offset(, 1).Select
    res = MsgBox("Do you want to continue Yes/No", vbYesNo)
    If res = vbYes Then
        Exit Sub
    End If
End If
Loop Until res <> vbYes

Selection.Offset(1, 1).Select

End Sub

Open in new window

Can you upload sample and show result after one cycle (please, mark start and end positions)?
Fabrice LambertFabrice LambertCommented:
Well, well well....

Let's not abuse the selection object, as it is user dependant and by nature chaotic.
As a developper, you don't want to use chaotic objects. Prefer refencing explicitly the objects you need.
Also, don't "select" cells, it is slow as hell !
Prefer using named parameters when possible, it give more meaning to your code.

Plus, your code is missing a lot of limit tests:
What if the current row is the 1st one ? You can't go up.

Concerning your issue, try the following:
Option Explicit

Public Sub macro()
    Dim wb As Excel.Workbook
    Dim ws As Excel.Worksheet
    Dim rng As Excel.Range
    Dim continue As Boolean
        '// retrieve the workbook running the code
    Set wb = ThisWorkbook
        '// replace 1 by the N0 of the sheet you're working on
    Set ws = wb.Worksheets(1)
    If (TypeName(ws.Selection) = "Range") Then
            '// retrieve current location (do that only once)
        Set rng = ws.Selection
        If (rng.Row > 1) Then
                    '// move one row to the top
                Set rng = rng.Offset(rowoffset:=-1)
                    '// test for alphanumeric value
                If (isAlphaNumeric(rng)) Then
                        '// move one row down, type the word "Filled" and move one row to the right
                    Set rng = moveDownRight(rng, "Filled")
                    If (MsgBox("Do you want to continue", vbYesNo + vbQuestion) = vbYes) Then
                        continue = True '// if yes, keep looping
                        continue = False '// if no, it will exit
                    End If
                    moveDownRight rng
                    continue = False
                End If
            While continue
            Set rng = Nothing
        End If
    End If
    Set ws = Nothing
    Set wb = Nothing
End Sub

Public Function isAlphaNumeric(ByRef rng As Excel.Range) As Boolean
        isAlphaNumeric = rng.value Like "*[A-Za-z0-9]*"
End Function

Public Function moveDownRight(ByRef startRng As Excel.Range, Optional ByVal value As String = vbNullString) As Excel.Range
    Dim rng As Excel.Range
    Set rng = startRng
    Set rng = rng.Offset(rowoffset:=1)
    If (value <> vbNullString) Then
        rng.value = value
    End If
    Set rng = rng.Offset(columnoffset:=1)
    Set moveDownRight = rng
End Function

Open in new window

brothertruffle880Author Commented:
Thanks!  Just what I needed.  I can fill in the rest of the commands needed.
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.