Highlight mismatched entries in single dynamic column and present msgbox for entire range

StackOverflow https://stackoverflow.com/questions/20360201

  •  28-08-2022
  •  | 
  •  

Question

I am new here and relatively new to VBA, so please bear with me. I looked around for an answer to this but couldn't find anything, so I apologize if this has already been answered elsewhere and I didn't find it.

I want to search through a specified column of dynamic length and replace the demographics with a system of numbers (the replace code below works fine, but if you have efficiency-related suggestions, by all means go ahead!). Then what I want to happen is to highlight any entries that do not match the numbers -- these would be strings saying, for example, "Manager" instead of "Boss" or something like that -- and have a message box pop up requesting the user manually code in the highlighted fields.

Currently what is happening is I have Conditional Formatting for any entries that do not match so they get highlighted. My "For Each Cell" populates a message box for each individual entry it finds, but I just want one message box for the entire range. Would it be better to highlight the mismatched entries through VBA? How? How can I code this to only give one message box for the whole range?

Thank you in advance for any help!

Sub ReplaceRaterDemographicCodes()
'Find and replace demographics with their corresponding codes.
Columns("H:H").Select
    With Selection
        .Replace What:="Self", Replacement:="78"
        .Replace What:="Boss", Replacement:="74"
        .Replace What:="Boss 1", Replacement:="74"
        .Replace What:="Peer", Replacement:="75"
        .Replace What:="Direct Report", Replacement:="76"
        .Replace What:="Customer", Replacement:="77"
        .Replace What:="Other", Replacement:="79"
        .Replace What:="Boss 2", Replacement:="72"
        .Replace What:="Boss 3", Replacement:="73"
    End With
    For Each Cell In Range("H2:H" & Range("H" & Rows.Count).End(xlUp).Row).Select
        If Not Cell.Value = 72 And Not Cell.Value = 73 And _
        Not Cell.Value = 74 And Not Cell.Value = 75 And Not Cell.Value = 76 And _
        Not Cell.Value = 77 And Not Cell.Value = 78 And Not Cell.Value = 79 And _
        Not Cell.Value = "" Then
            MsgBox ("There are uncommon demographics listed. Please modify as needed.")
        End If
    Next Cell
End Sub
Was it helpful?

Solution

Since you don't really need to loop through everything - just until you know that you want to show the message box, you can just exit the for loop after showing the message box:

Sub ReplaceRaterDemographicCodes()
...

For Each Cell In Range("H2:H" & Range("H" & Rows.Count).End(xlUp).Row).Select
    If Not Cell.Value = 72 And Not Cell.Value = 73 And _
    Not Cell.Value = 74 And Not Cell.Value = 75 And Not Cell.Value = 76 And _
    Not Cell.Value = 77 And Not Cell.Value = 78 And Not Cell.Value = 79 And _
    Not Cell.Value = "" Then
        MsgBox ("There are uncommon demographics listed. Please modify as needed.")
        Exit For
    End If
Next Cell
End Sub

This way the message box is only shown once and only if it fits your criteria.

OTHER TIPS

In conjunction with @jgridley here is an answer that includes a MsgBox for "All clear!". The .Select at the end of the For Each line is also removed (as this caused errors). Cells highlighted in red are done with Conditional Formatting.

Sub ReplaceRaterDemographicCodes()

Dim bAllClear As Boolean
bAllClear = True

...

For Each Cell In Range("H2:H" & Range("H" & Rows.Count).End(xlUp).Row)
    If Not Cell.Value = 72 And Not Cell.Value = 73 And _
    Not Cell.Value = 74 And Not Cell.Value = 75 And Not Cell.Value = 76 And _
    Not Cell.Value = 77 And Not Cell.Value = 78 And Not Cell.Value = 79 And _
    Not Cell.Value = "" Then
        bAllClear = False
Exit For
End If
Next Cell

If bAllClear = True Then
    MsgBox ("All clear!")
    Else
    MsgBox ("There are uncommon demographics listed." & vbNewLine & _
        vbNewLine & "Please modify the cells highlighted in red.")
End If
End Sub
Licensed under: CC-BY-SA with attribution
Not affiliated with StackOverflow
scroll top