VBA macro for comparing 4 columns and highlight

[geomano]

Hi,

I am trying to create a Macro, which will run through 4 columns (2 in each tab) and highlight the values, which are duplicated ONLY if there is a match between 2 rows in each tab.

I am using the code below:

Sub Dups()    Dim rCriteria As Range
    Dim rData As Range
    Dim c As Range, R As Range
    Dim sFirstAddress As String
    Dim ColorCounter As Long
    Dim StartTime As Single, EndTime As Single


Set rCriteria = Sheets(1).Range("a2:b1000")
Set rData = Sheets(2).Range("a2:b1000")


Application.ScreenUpdating = False


With rData
    .Interior.ColorIndex = xlNone


For Each R In rCriteria
    If Not R = "" Then
    Set c = .Find(what:=R.Value, LookIn:=xlValues, lookat:=xlWhole, _
            searchdirection:=xlNext)
    If Not c Is Nothing Then
        sFirstAddress = c.Address


        Do
            Set c = .FindNext(c)
            c.Interior.Color = vbYellow
            ColorCounter = ColorCounter + 1
        Loop Until c.Address = sFirstAddress
    End If
    End If
Next R


End With


Application.ScreenUpdating = True


End Sub

It seems that there is an issue with range, as macro is highlighting every row, where there is a match between only 1 row.

I am attaching the workbook.

Many thanks for help with this.

[MickG]

Try this:-

sub Dups()
Private Sub CommandButton2_Click()
Dim Rng As Range, Dn As Range
With Sheets("Sheet1")
    Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In Rng
    .Item(Dn.Value & Dn.Offset(, 1).Value) = Empty
Next
With Sheets("Sheet2")
    Set Rng = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
End With
For Each Dn In Rng
    If .exists(Dn.Value & Dn.Offset(, 1).Value) Then
        Dn.Resize(, 2).Interior.Color = vbYellow
    End If
Next
End With
End Sub

[geomano]

Thank you very much MickG, that's precisely what I tried to do.

[MickG]

You're welcome