VBA 循环突出不一致

Question

我有一个包含两列（A 和 B）的电子表格。我想（FOR）循环遍历 B 列，直到两个或多个单元格值匹配。对于在 B 列中匹配的单元格，我想遍历它们在 A 列中的对应值。如果它们的对应值不相同，我希望所有涉及的行都被突出显示。

我知道它不正确/不完整，但以下是我想遵循的基本结构。非常感谢任何和所有帮助。谢谢。

Sub MySUb()
  Dim iRow As Integer

  For iRow = 2 To ActiveSheet.UsedRange.Rows.Count
    If Trim(range("A" & iRow)) <> "" And Trim(range("B" & iRow)) = Trim(range("B" & iRow)) Then
      range("A" & iRow, "B" & iRow).Interior.ColorIndex = 6
    End If
  Next
End Sub

Answer 1

你可以先根据B列排序，然后修改你的代码为：

Sub MySUb()
  Dim iRow As Integer

  For iRow = 1 To ActiveSheet.UsedRange.Rows.Count
    If Trim(Range("A" & iRow).Text) <> "" And _
    Trim(Range("B" & iRow).Text) = Trim(Range("B" & iRow + 1).Text) And _
    Trim(Range("A" & iRow).Text) <> Trim(Range("A" & iRow + 1).Text) Then
      Range("A" & iRow, "B" & iRow).Interior.ColorIndex = 6
      Range("A" & iRow + 1, "B" & iRow + 1).Interior.ColorIndex = 6
    End If
  Next
End Sub

编辑： 这是一个更好的解决方案，它可以处理在 B 列中有 >2 个匹配单元格但 A 中的相应单元格不匹配（即其中至少一个是不同的）的情况。在这种情况下，所有这些单元格都会被标记。

 Sub MySUb()
  Dim iRow As Integer
  Dim jRow As Integer
  Dim kRow As Integer

  For iRow = 1 To ActiveSheet.UsedRange.Rows.Count
    'If Trim(Range("A" & iRow).Text) <> "" Then
    For jRow = iRow To ActiveSheet.UsedRange.Rows.Count 'Finds the last non-matching item in B
     If Trim(Range("B" & jRow).Text) <> Trim(Range("B" & iRow).Text) Then
       Exit For
     End If
    Next jRow
    For kRow = iRow To jRow - 1
     If Trim(Range("A" & iRow).Text) <> Trim(Range("A" & kRow).Text) Then
      Range("A" & iRow, "B" & kRow).Interior.ColorIndex = jRow + 1 'Or can be 6
     End If
    Next kRow
  Next iRow
End Sub

Answer 2

这样的事情怎么样，使用字典跟踪 B 列中项目的实例，然后为 B 列值的每个唯一实例测试 A 列值。如果匹配失败，则标记所有实例。

Sub DuplicateChecker()
    Dim rngColumnB As Range
        Set rngColumnB = Range("B2", Range("B2").End(xlDown))
    Dim rngCell As Range
    Dim rngDupe As Range
    Dim rngDuplicateB As Range
    Dim dctValuesChecked As Dictionary 
        'requires enabled reference library for 'Microsoft Scripting Runtime'
        Set dctValuesChecked = New Dictionary
    Dim strColumnAValue As String

    For Each rngCell In rngColumnB
        strColumnAValue = rngCell.Offset(0, -1).Value
        If Not dctValuesChecked.Exists(Trim(rngCell.Value)) Then
            Call dctValuesChecked.Add(rngCell.Value, rngCell.Row)
        Else
            Set rngDuplicateB = FindItemsInRange(rngCell.Value, rngColumnB)
            rngDuplicateB.EntireRow.Select
            For Each rngDupe In rngDuplicateB
                If Not rngDupe.Offset(0, -1).Value = strColumnAValue Then
                    rngDuplicateB.Interior.ColorIndex = 6
                    rngDuplicateB.Offset(0, -1).Interior.ColorIndex = 6
                End If
            Next rngDupe
        End If
    Next rngCell
End Sub

Function FindItemsInRange(varItemToFind As Variant, _
                            rngSearchIn As Range, _
                            Optional LookIn As XlFindLookIn = xlValues, _
                            Optional LookAt As XlLookAt = xlPart, _
                            Optional blnMatchCase As Boolean = False) As Range

'adapted from a function by Aaron Blood found on the Ozgrid forums:
'http://www.ozgrid.com/forum/showthread.php?t=27240

    With rngSearchIn
        Dim rngFoundItems As Range
            Set rngFoundItems = .Find(What:=varItemToFind, _
                                            LookIn:=LookIn, _
                                            LookAt:=LookAt, _
                                            SearchOrder:=xlByRows, _
                                            SearchDirection:=xlNext, _
                                            MatchCase:=blnMatchCase, _
                                            SearchFormat:=False)

        If Not rngFoundItems Is Nothing Then
            Set FindItemsInRange = rngFoundItems
            Dim strAddressOfFirstFoundItem As String
                strAddressOfFirstFoundItem = rngFoundItems.Address
            Do
                Set FindItemsInRange = Union(FindItemsInRange, rngFoundItems)
                Set rngFoundItems = .FindNext(rngFoundItems)
            Loop While Not rngFoundItems Is Nothing And _
                            rngFoundItems.Address <> strAddressOfFirstFoundItem
        End If
    End With
End Function