问使用范围查找重复项的VBA宏

EN

Option Explicit
Sub ColorCriteria()
    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

StartTime = Timer
Set rCriteria = Range("B5:B405")
Set rData = Range("D5:OM1004")

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
        c.Interior.Color = vbRed

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

End With
Application.ScreenUpdating = True
EndTime = Timer

MsgBox ("Execution Time: " & Format(EndTime - StartTime, "0.000"" sec""") _
    & vbLf & "Colored Cell Count: " & ColorCounter)


End Sub

Set aktSheet = Application.ActiveWorkbook.Worksheets("Sheet1")
counter = 0
For Each c In aktSheet.Range("D5:OM1004").Cells
    If c.DisplayFormat.Interior.ColorIndex = 38 Then
        counter = counter + 1
    End If
Next