VBA Loop to Highlight Inconsistencies - vba

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

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

Answer 2

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