Compare Entry to Other Cells

[aboly8000]

OK. Try this. I put all the ranges that may change at the very top as range variables. So those should be the only three things in the code that you may need to change.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng1 As Range
    Dim rng2 As Range
    Dim isect As Range
    Dim isect2 As Range
    Dim cell As Range
    Dim dd() As Variant
    Dim i As Long
    Dim mtch As Boolean
    Dim msg As String
    Dim myEntries As String
    Dim ddRange As Range
    
'***Set column E validation range
    Set rng1 = Range("E7:E12")
'***Set column A validation range
    Set rng2 = Range("A1:A100")
'***Set drop-down list value range
    Set ddRange = Sheets("Sheet1").Range("A1:A3")
    
    
'   See if any updated cells fall in column E range
    Set isect = Intersect(rng1, Target)
'   See if any updated cells fall in column A range
    Set isect2 = Intersect(rng2, Target)
    
'   Exit if updated cells do not fall in either validation range
    If (isect Is Nothing) And (isect2 Is Nothing) Then Exit Sub
    
    Application.EnableEvents = False


'   First check (column E)
    If Not isect Is Nothing Then
'       Build array of drop-down values
        ReDim dd(ddRange.Cells.Count)
        i = 0
        For Each cell In ddRange
            dd(i) = cell.Value
            i = i + 1
        Next cell
    
'       Loop through all intersecting cells
        For Each cell In isect
'           See if cell entry matches any drop-down values
            mtch = False
            For i = LBound(dd) To UBound(dd)
                If cell.Value = dd(i) Then
                    mtch = True
                    Exit For
                End If
            Next i
'           If value is not in list, erase and return message
            If mtch = False Then
                cell.ClearContents
                msg = msg & cell.Address(0, 0) & ","
            End If
        Next cell


'       Build string of validation entries
        For i = LBound(dd) To UBound(dd)
            myEntries = myEntries & dd(i) & ","
        Next i
        myEntries = Left(myEntries, Len(myEntries) - 1)
    
'       Reset validation
        With rng1.Validation
            .Delete
            .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                xlBetween, Formula1:=myEntries
        End With
    
'       Return message, if necessary
        If Len(msg) > 0 Then
            MsgBox "Invalid entries in cells: " & vbCrLf & Left(msg, Len(msg) - 1), vbOKOnly, "ERROR!"
        End If
    End If
    

'   Second check (column A)
    If Not isect2 Is Nothing Then
'       Loop through all intersecting cells
        For Each cell In isect2
            If (Len(cell) > 0) And (Len(cell) <> 11) Then
                cell.ClearContents
                msg = msg & cell.Address(0, 0) & ","
            End If
        Next cell
            
'       Reset validation
        With rng2.Validation
            .Delete
            .Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
                Operator:=xlEqual, Formula1:="11"
        End With
    
'       Return message, if necessary
        If Len(msg) > 0 Then
            MsgBox "Invalid entries in cells: " & vbCrLf & Left(msg, Len(msg) - 1), vbOKOnly, "ERROR!"
        End If
    End If
    
    Application.EnableEvents = True

End Sub

hi
I want to display an error message for range ("E7: E12"), whenever the value is one with columns ("F7: F12") or ("G7: G12") or ("H7: H12") or ("I7: I12").
For example, when E7 is equal to F7 or G7 or H7 or I7, display an error message.
please help

 

[aboly8000]

If I am understanding you correctly, try this. I think it will do all that you want.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng As Range
    Dim cell As Range
    Dim r As Long, c As Long
    Dim i As Long
    
'   See if any cells updated in range E7:H12
    Set rng = Intersect(Target, Range("E7:H12"))
    If rng Is Nothing Then Exit Sub
    
'   Loop through updated cells in E7:H12
    For Each cell In rng
        c = cell.Column
        r = cell.Row
        Application.EnableEvents = False
'       See if value is added or removed
        If cell = "" Then
'           What to do if value removed (clear columns to right)
            Range(Cells(r, c + 1), Cells(r, 9)).ClearContents
        Else
'           Check to do if value added (check to see if rest of columns match)
            For i = (c + 1) To 9
                If cell = Cells(r, i) Then
                    cell.ClearContents
                    MsgBox "Value in cell " & cell.Address(0, 0) & _
                        " cannot match any value in " & Cells(r, i).Address(0, 0), vbOKOnly, "ENTRY ERROR!"
                End If
            Next i
        End If
        Application.EnableEvents = True
    Next cell

End Sub

Hello
Thank you very much for taking the time to write this code for me.
I made a few changes to the plan and reached my goal.

Private Sub Worksheet_Change(ByVal Target As Range)


    Dim rng As Range
    Dim cell As Range
    Dim r As Long, c As Long
    Dim i As Long
    Dim j As Long
'   See if any cells updated in range E7:H12
    Set rng = Intersect(Target, Range("E7:H12"))
    If rng Is Nothing Then Exit Sub
    
'   Loop through updated cells in E7:H12
    For Each cell In rng
        c = cell.Column
        r = cell.Row
        Application.EnableEvents = False
'       See if value is added or removed
        If Cells(r, 5) <> "" Then
          If cell = "" Then
'           What to do if value removed (clear columns to right)
            Range(Cells(r, c), Cells(r, 8)).ClearContents
          Else
        
'           Check to do if value added (check to see if rest of columns match)
            For i = 5 To (c - 1)
                If cell = Cells(r, i) Or Cells(r, i) = "" Then
                    cell.ClearContents
                    Range(Cells(r, c), Cells(r, 8)).ClearContents
                End If
            Next i
            For j = (c + 1) To 8
                If cell = Cells(r, j) Then
                    cell.ClearContents
                    If c = 5 Then
                    Range(Cells(r, c), Cells(r, 9)).ClearContents
                    Else
                    Range(Cells(r, c), Cells(r, 8)).ClearContents
                    End If
                End If
            Next j
            
          End If
        Else
        cell.ClearContents
        Range(Cells(r, c), Cells(r, 9)).ClearContents
        End If
        
        Application.EnableEvents = True
    Next cell


End Sub

 

[Joe4]

You are welcome.