VBA循环突出不一致

我有一个包含两列（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列进行sorting，然后修改您的代码：

 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 

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

  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值的每个唯一实例testing列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