VBA Macro to find Duplicates using Ranges

0
votes

VBA noob here, been searching for 2 days to find a script i can modify for my needs but keep getting stuck or not be able to make anything work for my specific situation.

I'm trying to write a simple but specific macro to find and color duplicates in ranges.

My search criteria is in Range(B5:B405) Data to be scanned and colored is located in Range(D5:OM1004)

The data is only numbers and needs to be an exact match to the search criteria, if cell in data is found to exist in search criteria then data cell is filled red.

I also need to stop the script at data row 1004 and display a message with total execution time at the end.

I can do this in seconds with Conditional Formatting but I need to count the colored cells after and no VBA Macros i can find will let me count conditionally formatted colors, even been through all of cpearson's site without success.

2
vbaexcel
Sample of data and relevant output might help us suggest you different options on how to go about it. - Siddharth Rout
Hi Sid, the criteria and data are only comprised of numbers. for example if B5=1 and D10, F5, OA100 =1 then D10, F5 and OA100 will have a red fill. I hope that clears it up a little? - VBA-Noob

2 Answers

1
votes

Try this:

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
1
votes

Indeed the solution is perfect. But just to clarify, that also the initial approach with counting conditional formated cells could work starting with Excel 2010. There the color can be identified and then the cells counted with something like this

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