I'm trying to find a more efficient way to highlight duplicate cells between two ranges on different worksheets. The code below is painfully slow:
Sub HighlightDuplicates()
Application.DisplayAlerts = False
lrU = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
lrPT = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Dim rng1, rng2, cell1, cell2 As Range
Set rng1 = Worksheets("Sheet1").Range("DL4:DL" & lrU)
Set rng2 = Worksheets("Sheet2").Range("E3:M" & lrPT)
For Each cell1 In rng1
For Each cell2 In rng2
If cell1.Value = cell2.Value Then
cell1.Font.Bold = True
cell1.Font.ColorIndex = 2
cell1.Interior.ColorIndex = 3
cell1.Interior.Pattern = xlSolid
cell2.Font.Bold = True
cell2.Font.ColorIndex = 2
cell2.Interior.ColorIndex = 3
cell2.Interior.Pattern = xlSolid
End If
Next cell2
Next cell1
Application.DisplayAlerts = True
End Sub
Any suggestions on a more efficient method?
Thanks for any help.
Regards,
Putting my comments together, you could modify your code to look something like this (untested)
Sub HighlightDuplicates()
Application.DisplayAlerts = False
application.calculation=xlcalculationmanual
application.screenupdating=false
lrU = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
lrPT = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Dim rng1, rng2, cell1, cell2 As Range
Set rng1 = Worksheets("Sheet1").Range("DL4:DL" & lrU)
Set rng2 = Worksheets("Sheet2").Range("E3:M" & lrPT)
For Each cell2 In rng2
Set cell1 = rng1.Find(cell2, lookin:=xlValues)
if not cell1 is nothing then
firstAddress = cell1.address
Do
cell1.Font.Bold = True
cell1.Font.ColorIndex = 2
cell1.Interior.ColorIndex = 3
cell1.Interior.Pattern = xlSolid
cell2.Font.Bold = True
cell2.Font.ColorIndex = 2
cell2.Interior.ColorIndex = 3
cell2.Interior.Pattern = xlSolid
Set cell1 = rng1.FindNext(cell2)
Loop While Not cell1 Is Nothing And cell1.Address <> firstAddress
end if
next cell1
application.displayalerts=true
application.calculation=xlcalculationmanual
application.screenupdating=true
end sub
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.