PDA

View Full Version : [SOLVED] VBA macro for comparing 4 columns and highlight



geomano
03-07-2017, 02:26 PM
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
03-08-2017, 04:12 AM
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
03-08-2017, 10:50 AM
Thank you very much MickG, that's precisely what I tried to do.

MickG
03-09-2017, 05:30 AM
You're welcome