突出显示多个范围之间但不在范围内的重复单元格

Question

范围 A 是 B1:E2000（实际上应该是 B1:B500、C1:C1000、D1:D1500、E1:E2000）。

范围 B 为 G1:G2000。

范围 C 是 I1:AH2000。

第 1 步：如果单元格出现在范围 A 和范围 C 中，我希望它们以黄色突出显示。

第 2 步：然后，如果一个单元格出现在范围 A 和范围 B 中，我希望它们突出显示为绿色。这样做的目的是突出显示已在步骤 1 中以黄色突出显示的单元格。

第 3 步：然后，如果一个单元格出现在区域 B 中并且在区域 C 中出现两次以上，我希望它们突出显示为红色。这样做的目的是突出显示已在步骤 1 中突出显示为黄色或在步骤 2 中突出显示为绿色的单元格。

第 4 步：否则，不应突出显示单元格。如果突出显示的单元格包含稍后删除的文本，那么当我再次运行宏时，我希望取消突出显示空单元格。

我不关心在范围内的重复。

我几乎可以在条件格式中解决这个问题，但是 CF 是“易变的”，我希望每次尝试滚动时都避免滞后（不过，这也部分是因为我的 CF 是非常低效），所以我非常乐意在需要时使用 VBA 宏来运行它。 （当然，如果有更好的方法来使用条件格式，我不会拒绝。）

如果你真的想看看我为获得类似结果而将我找到的代码拼凑起来的糟糕而骇人听闻的尝试，那就这样吧：

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

很明显，我对自己在做什么并没有明确的想法，而且我终其一生都无法弄清楚如何跨多个范围工作。它显然也没有按预期运行。此外，这是针对每个单元格检查每个单元格，这对于我正在尝试做的事情来说显然是非常低效的。

我对宏知之甚少（不过，我曾经在高中时涉足过），而且我似乎已经超出了我的深度。

我知道我要的是鱼，而不是你教我如何钓鱼。我正在从基础开始工作，但进展缓慢，我感觉距离现在能够正确完成我想要的事情还有很长的路要走。

Answer 1

见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