检查 Range1 中的所有值与 Range 2 中的所有值是否完全匹配

Question

我正在尝试比较 Range1 中的所有值（活动行的 U:X 中的单元格），不包括空格，与 Range2 中的所有值（m，n），不包括空格，并且 - 如果两者之间存在完全匹配范围 - 更改活动行中 Y 列的颜色，否则不更改颜色。

例子：

Range1 包含 Dog, Cat, Bird, [空白单元格], Range2 包含 Dog, Cat, Bird, [多个空白单元格] = MATCH

Range1 包含 Dog、Cat、[空白单元格]、[空白单元格]，Range2 包含 Dog、Cat、Bird，[多个空白单元格] = NO MATCH

这是我目前所拥有的，但是当完全匹配时 yColumn 不会改变颜色。我需要另一个循环吗？

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim cVal As String
    Dim tRow, lRow As Long
    Dim pID As String
    Dim yColumn As Integer
    cVal = Sheet1.Cells(Target.Row, Target.Column).Value
    tRow = Target.Row
    yColumn = 25
    lRow = Sheet4.Range("A1200").End(xlUp).Row
    pID = Sheet1.Range("A" & tRow).Value
    
' Check for ALL Cells Match
        If Not Intersect(Target, Range("U2:X1500")) Is Nothing Then
            Sheet1.Cells(tRow, yColumn).Interior.Color = xlNone
                For m = 2 To lRow
                    If Sheet4.Range("A" & m).Value = pID Then
                For n = 11 To 28
                        If Sheet4.Cells(m, n).Value = cVal And Sheet4.Cells(m, n).Value <> "" And Target(Range("U2:X1500")) = Sheet4.Cells(m, n).Value Then
                        Sheet1.Cells(tRow, yColumn).Interior.Color = 914271
                        Exit Sub
                        End If
                Next n
                    End If
                Next m
        End If
End Sub

Answer 1

请测试下一个方法：

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lRow As Long, pID As String, yColumn As Long, m As Long
    Dim arrUX, arrKAB, El1, El2, boolFound As Boolean
    yColumn = 25
    lRow = Sheet4.Range("A" & rows.Count).End(xlUp).row
    pID = Me.Range("A" & Target.row).Value
    
        If Not Intersect(Target, Range("U2:X1500")) Is Nothing Then
            Target.Interior.color = xlNone
            For m = 2 To Target.row
                If Sheet4.Range("A" & m).Value = pID Then
                    arrUX = Me.Range(Me.cells(Target.row, "U"), Me.cells(Target.row, "X")).Value
                    arrKAB = Sheet4.Range(arrKAB.cells(m, "K"), Sheet4.cells(m, "AB")).Value
                    For Each El1 In arrUX
                        boolFound = False
                        For Each El2 In arrKAB
                            If El1 <> "" Then
                                If El1 = El2 Then boolFound = True: Exit For
                            End If
                        Next
                        If Not boolFound Then Exit Sub 'if one element of the first array is not found, existing
                    Next El1
                    If boolFound Then
                        Application.EnableEvents = False
                         Target.Interior.color = 914271
                        Application.EnableEvents = True
                        Exit Sub 'since only one occurrence should exist...
                    End If
                End If
            Next m
        End If
End Sub

Answer 2

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim v, lr As Long, tRow As Long
    Dim s1 As String, s2 As String
    Dim pID As String, c As Range
    
    If Intersect(Target, Range("U:X")) Is Nothing Then
         Exit Sub
    End If
    
    tRow = Target.Row
    For Each c In Sheet1.Range("U1:X1").Offset(tRow - 1)
        If Len(c) > 0 Then
            s1 = s1 & Trim(c) & "|"
        End If
    Next

    ' find on sheet 4
    pID = Sheet1.Range("A" & tRow).Value
    With Sheet4
        lr = .Cells(.Rows.Count, "A").End(xlUp).Row
        v = Application.Match(pID, .Range("A1:A" & lr), 0)
        If IsError(v) Then Exit Sub
        
        For Each c In .Range("K1:AB1").Offset(v - 1)
            If Len(c) > 0 Then
                 s2 = s2 & Trim(c) & "|"
            End If
        Next
        
        If s1 = s2 Then
            Sheet1.Cells(tRow, 25).Interior.Color = 914271
        Else
            Sheet1.Cells(tRow, 25).Interior.Color = xlNone
        End If
       
    End With
    
End Sub