在不同的工作表上突出顯示兩個范圍之間的重復

Question

我試圖找到一種更有效的方法來突出顯示不同工作表上兩個范圍之間的重復單元格。 下面的代碼非常緩慢：

    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

對更有效的方法有何建議？

謝謝你的幫助。

問候，

Answer 1

將我的評論放在一起，您可以修改代碼，使其看起來像這樣（未經測試）

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