Highlight cells that don’t meet the drop down criteria

Question

I have a spreadsheet that has drop-down options and people keep copying and pasting entries that do not fit the drop down options.

I’ve created a VBA that scans a worksheet and an error message appears with the cells where there’s entries that don’t fit the drop down option. I just need it to actually highlight in yellow the cells that need to be changed so they can be located easily. Please can someone help?

This is my current VBA:

Sub TestValidation()
 
Dim myRng As Range
Dim ErrorMsg As String
Dim NoErrorMsg As String
Dim FoundCells As String
Dim cell As Range
 
Set myRng = Sheets("Portfolio Tracker").Range("D3:AK5000")
ErrorMsg = "You've entered something in a drop-down box cell that isn't a drop-down box option. Please change"
NoErrorMsg = "No cells that do not abide to validation"
FoundCells = ""
For Each cell In myRng
   If Not cell.Validation.Value Then
      FoundCells = FoundCells & "," & cell.Address
   End If
   Next cell
If Len(FoundCells) >= 1 Then
   MsgBox ErrorMsg & Right(FoundCells, Len(FoundCells) - 1)
Else
   MsgBox NoErrorMsg
End If
Set myRng = Nothing
 
End Sub

Answer 1

You can use the Worksheet_Change event and if someone pastes invalid values it will undo the pasting and throw a message.

Note that you will need to use DataValidation in addition with this procedure.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim RevertChanges As Boolean
    
    Const WatchedRange As String = "D3:AK5000"
    
    On Error GoTo ENABLE_EVENTS  ' in case of error enable events
    Application.EnableEvents = False
    
    
    Dim AffectedCells As Range
    Set AffectedCells = Intersect(Target, Me.Range(WatchedRange))
    
    If Not AffectedCells Is Nothing Then
        Dim ValidationType As Variant
        ValidationType = AffectedCells(1).Validation.Type
        
        If Not IsEmpty(ValidationType) Then
            Dim Cell As Range
            For Each Cell In AffectedCells
                If Cell.Value <> "" Then
                    If Not Cell.Validation.Value Then
                        RevertChanges = True
                        Exit For
                    End If
                End If
            Next Cell
        Else
            RevertChanges = True
        End If
        
        If RevertChanges Then
            MsgBox "Invalid values were pasted. Undo pasting.", vbCritical, "Computer Says No"
            Application.Undo
        End If
    End If
    
ENABLE_EVENTS:
    Application.EnableEvents = True
End Sub

Alternatively just use data validation for the drop downs and then use Sheets("Portfolio Tracker").CircleInvalid to circle the invalid values: