VBA Loop to Highlight Inconsistencies

Question

I have a spreadsheet with two columns (A and B). I would like to (FOR) loop through column B until two or more of the cell values match. For the cells that match in column B, I would like to loop through their corresponding values in column A. If their corresponding values are not identical, I want all of the rows involved to be highlighted.

I know it's not right/complete, but below is the basic structure I would like to follow. Any and all help is greatly appreciated. Thank you.

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

How about something like this, using a dictionary to track the instances of an item in Column B and then testing the Column A values for each unique instance of Column B values. If one fails to match then all instances are marked.

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

Answer 2

You can first sort based on Column B, then modify your code to:

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

EDIT: Here is a better solution which can handle the case where in column B there >2 matching cells, but the corresponding cells in A do not match (i.e. at least one of them is different). In this case all of those cells are marked.

 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