Highlight duplicate cells between multiple ranges but not within ranges

Question

Range A is B1:E2000 (really, it should be B1:B500, C1:C1000, D1:D1500, E1:E2000).

Range B is G1:G2000.

Range C is I1:AH2000.

Step 1: If a cell appears in Range A and Range C, I want them highlighted yellow.

Step 2: Then, if a cell appears in Range A and Range B, I want them highlighted green. It is intended that this may highlight over cells already highlighted yellow by Step 1.

Step 3: Then, if a cell appears in Range B and more than twice in Range C, I want them highlighted red. It is intended that this may highlight over cells already highlighted yellow by Step 1 or highlighted green by Step 2.

Step 4: Otherwise, a cell should not be highlighted. If a highlighted cell has text that is later deleted, then, when I run the macro again, I would want the empty cell to be un-highlighted.

I do not care about duplicates within the ranges themselves.

I can almost figure this out in Conditional Formatting, but CF is "volatile", and I want avoid lag every time I try to scroll (though, that's also in part due to my CF being horribly inefficient), so I'm more than happy to use a VBA macro to run it when I need it. (Of course, if there is a better way to do it with Conditional Formatting, I'm not going to say no.)

If you really want to see my awful and hacky attempt at cobbling together code I found for similar results, so be it:

Sub HighlightDuplicates()

    Dim cells As Range
    Dim cell As Range
    Set cells = Range("B1:AH2000")

    For Each cell In cells
        If WorksheetFunction.CountIf(cells, cell.Value) > 3 Then
            cell.Interior.ColorIndex = 3
        ElseIf WorksheetFunction.CountIf(cells, cell.Value) > 2 Then
            cell.Interior.ColorIndex = 4
        ElseIf WorksheetFunction.CountIf(cells, cell.Value) > 1 Then
            cell.Interior.ColorIndex = 6
        Else
            cell.Interior.ColorIndex = 0
        End If
    Next cell

End Sub

It's clear that I don't have a strong idea of what I'm doing, and I could not for the life of me figure out how to work across multiple ranges. It obviously doesn't function as intended either. Furthermore, this is checking every cell against every cell, which is obviously horribly inefficient for what I'm trying to do.

I know very little about macros (though, I used to dabble back in high school), and it seems I'm way out of my depth.

I know that I'm asking for fish and not for you to teach me how to fish. I'm working on starting from the basics, but it has been slow-going, and I feel miles away from being able to properly accomplish what I want right now.

Is there a reason you are not using conditional formatting for this? — cybernetic.nomad
As I said, when I was using Conditional Formatting, it really slowed down Excel, but that was also likely also due to my CF being quite inefficient. If it works better as CF, I'm more than happy to do it that way. — Raekai

CDP1802 CDP1802 · Accepted Answer · 2020-02-03T18:58:31

See Dictionary Object

Option Explicit
Sub HighlightDuplicates()

    Dim ws As Worksheet, t0 As Single, t1 As Single
    Set ws = ThisWorkbook.Sheets("Sheet1")
    t0 = Timer

    'Step 4: Otherwise, a cell should not be highlighted.
    ws.Cells.ClearFormats

    Const RANGE_A As String = "B1:E2000"
    Const RANGE_B As String = "G1:G2000"
    Const RANGE_C As String = "I1:AH2000"

    Dim dictA As Object, dictB As Object, dictC As Object
    Set dictA = CreateObject("Scripting.Dictionary")
    Set dictB = CreateObject("Scripting.Dictionary")
    Set dictC = CreateObject("Scripting.Dictionary")

    Call buildDict(dictA, ws.Range(RANGE_A))
    Call buildDict(dictB, ws.Range(RANGE_B))
    Call buildDict(dictC, ws.Range(RANGE_C))

    'Step 1: If a cell appears in Range A and Range C highlighted yellow.
    'Step 2: Then, if a cell appears in Range A and Range B,
     'I want them highlighted green.
    Dim cell As Range, key As String
    For Each cell In ws.Range(RANGE_A)
        If Len(cell.Value) > 0 Then
            key = CStr(cell.Value)
            If dictC.exists(key) Then cell.Interior.Color = vbYellow
            If dictB.exists(key) Then cell.Interior.Color = vbGreen
        End If
    Next

    For Each cell In ws.Range(RANGE_C)
        If Len(cell.Value) > 0 Then
            key = CStr(cell.Value)
            If dictA.exists(key) Then cell.Interior.Color = vbYellow
        End If
    Next

    For Each cell In ws.Range(RANGE_B)
        If Len(cell.Value) > 0 Then
            key = CStr(cell.Value)
            If dictA.exists(key) Then cell.Interior.Color = vbGreen
        End If
    Next

    'Step 3: Then, if a cell appears in Range B and more than twice in Range C,
    'I want them highlighted red.

    For Each cell In ws.Range(RANGE_B)
        If Len(cell.Value) > 0 Then
            key = CStr(cell.Value)
            If dictC.exists(key) Then
                If dictC.Item(key) > 2 * dictB.Item(key) Then
                    cell.Interior.Color = vbRed
                End If
            End If
        End If
    Next

    For Each cell In ws.Range(RANGE_C)
        If Len(cell.Value) > 0 Then
            key = CStr(cell.Value)
            If dictB.exists(key) Then
                If dictC.Item(key) > 2 * dictB.Item(key) Then
                    cell.Interior.Color = vbRed
                End If
            End If
        End If
    Next
    t1 = Timer
    MsgBox "Completed in " & Int(t1 - t0) & " seconds"

End Sub

Sub buildDict(ByRef dict, ByRef rng)

    Dim cell As Range, key As String
    For Each cell In rng
        If Len(cell.Value) > 0 Then
            key = CStr(cell.Value)
            If Not dict.exists(key) Then
                dict.Add key, 1
            Else
                dict.Item(key) = dict.Item(key) + 1
            End If
        End If
    Next
    Debug.Print "Keys in " & rng.Address, dict.Count

End Sub

Highlight duplicate cells between multiple ranges but not within ranges

1 Answers