为范围内的不同重复值分配不同的颜色

Question

我正在尝试突出显示某个范围内的所有重复项。扭曲是我希望每个不同的值都有不同的颜色。例如，所有值“Apple”都是一种颜色。所有值“汽车”将是另一种颜色等。我找到了一种方法来做到这一点，尽管它只能在一个列上运行。我需要一些帮助才能让它在多个列上运行。这是我的示例的照片：

这是我正在运行的 VBA 代码，目前仅突出显示 C 列：

Sub different_colourTest2()
    Dim lrow As Integer
    lrow = Worksheets("Sheet2").Range("C2").CurrentRegion.Rows.Count - 1 + 2
    For N = 3 To lrow
        If Application.WorksheetFunction.CountIf(Worksheets("Sheet2").Range("C3:C" & lrow), Worksheets("Sheet2").Range("C" & N)) = 1 Then
            GoTo skip
        Else
            Worksheets("Sheet2").Range("C" & N).Interior.ColorIndex = Application.WorksheetFunction.Match(Worksheets("Sheet2").Range("C" & N), Worksheets("Sheet2").Range("C3:C" & lrow), 0) + 2
        End If
    skip:    Next N
        Worksheets("Sheet2").Activate
        Range("C3").Select
End Sub

如果有人能告诉我如何让它涵盖一系列不同的列和行，将不胜感激！

旁注：我也在寻找某种方法，当范围内的单元格为空时不返回错误。这不是重点，但如果有人对此有答案，也会很高兴听到它。

Answer 1

我采用的方法是将范围内的所有值排序到字典中，记录所有单元格相对于单元格值的地址。所以，我得到了一个像 "B2" 出现在 C20、E25、AG90 中的列表。在下一步中，对每个值应用不同的颜色。您可以准备尽可能多的颜色来设置，但如果没有足够的颜色，宏将在应用最后一种可用颜色后从第一种颜色重新启动。

Sub MarkDuplicates()
    ' 050

    ' adjust the constants to suit
    Const FirstRow      As Long = 20
    Const FirstColumn   As String = "C"
    Const LastColumn    As String = "AG"

    Dim Dict            As Object           ' values in you declared range
    Dim Ky              As Variant          ' dictionary key
    Dim Rng             As Range            ' column range
    Dim Arr             As Variant          ' data read from the sheet
    Dim Rl              As Long             ' last used row
    Dim Cols            As Variant          ' choice of colours
    Dim Idx             As Long             ' index for colour array
    Dim Sp()            As String           ' working array
    Dim C               As Long             ' loop counter: columns
    Dim R               As Long             ' loop counter: rows


    Cols = Array(65535, 10086143, 8696052, 15123099, 9359529, 11854022)
        ' add as many colours as you wish
        '    This is how I got the color numbers:-
        '    For Each Rng In Range("E3:E8")     ' each cell is coloured differently
        '        Debug.Print Rng.Interior.Color
        '    Next Rng

    Application.ScreenUpdating = False
    Set Dict = CreateObject("Scripting.Dictionary")
    With Worksheets("Sheet1")               ' replace the sheet name to match your Wb
        For C = Columns(FirstColumn).Column To Columns(LastColumn).Column
            Rl = .Cells(.Rows.Count, C).End(xlUp).Row
            If Rl >= FirstRow Then
                Set Rng = .Range(.Cells(1, C), .Cells(Rl, C))
                Arr = Rng.Value
                For R = FirstRow To Rl
                    If Len(Arr(R, 1)) Then
                        ' record the address of each non-blank cell by value
                        Dict(Arr(R, 1)) = Dict(Arr(R, 1)) & "," & _
                                               Cells(R, C).Address
                    End If
                Next R
            End If
        Next C

        For Each Ky In Dict
            Sp = Split(Dict(Ky), ",")
            If UBound(Sp) > 1 Then                  ' skip unique values
                ' apply same colour to same values
                For C = 1 To UBound(Sp)
                    .Range(Sp(C)).Interior.Color = Cols(Idx)
                Next C
                Idx = Idx + 1
                ' recycle colours if insufficient
                If Idx > UBound(Cols) Then Idx = LBound(Cols)
            End If
        Next Ky
    End With
    Application.ScreenUpdating = True
End Sub

请务必将当前显示的工作表名称设置为“Sheet1”。您也可以通过修改代码顶部的常量值来调整工作范围。

Answer 2

我很抱歉这不是一个非常优雅的解决方案。我会使用一个集合（在这里字典可能会更好）。集合是一种数据结构，它只取一个特定的值一次。因此，如果某个单元格内容已经出现在其他地方，一个集合会让我知道我正在尝试向它添加一个已经添加到集合中的元素。通过这种方式，我可以很容易地看出这个元素是重复的。 类模块中的包装器是为了方便地使用具有各种数据结构的附加 Ms 库元素。

我将创建一个类（插入类模块并将其名称更改为 cls）。 转到 VBA 中的参考并检查 Microsoft Scripting Runtime。这是导入库以使用 VBA。

在类模块中粘贴 Scripting.Dictionary 的包装器。

Option Explicit

Private d As Scripting.Dictionary
Private Sub Class_Initialize()
    Set d = New Scripting.Dictionary
End Sub

Public Sub Add(var As Variant)
    d.Add var, 0
End Sub

Public Function Exists(var As Variant) As Boolean
    Exists = d.Exists(var)
End Function

Public Sub Remove(var As Variant)
    d.Remove var
End Sub

然后在普通的 VBA 模块中粘贴代码，该代码首先将在非空单元格中找到的所有新元素添加到集合中，然后为它们着色。首先，我们遍历所有非空单元格并将它们的内容添加到集合 allElements。同时我们添加到集合中的所有新元素称为重复。

在代码的第二部分，我们再次遍历所有非空单元格，如果它们的内容属于重复的集合，我们将改变它们的颜色。但是我们必须为具有相同内容的所有其他单元格设置相同的颜色，因此，我们使用嵌套循环。所有具有特定内容的单元格都具有相同的颜色。更改它们的颜色后，我们将它们的内容添加到另一个集合 - 着色，因此我们不会再次更改它们的颜色。

Sub different_colourTest2()

    Dim allElements As cls
    Dim repeated As cls
    Dim havecolors As cls
    Set allElements = New cls
    Set repeated = New cls
    Set havecolors = New cls
    Dim obj As Object
    Dim colorchoice As Integer
    Dim cell, cell2 As Range

   ' Go through all not empty cells and add them to allElements set
   ' If some element was found for the second time then add it to the set repeated
   For Each cell In ActiveSheet.UsedRange
        If IsEmpty(cell) = True Then GoTo Continue
        On Error Resume Next
        If (allElements.Exists(cell.Text) = True) Then repeated.Add (cell.Text)
        On Error GoTo 0
        If (allElements.Exists(cell.Text) = False) Then allElements.Add (cell.Text)

Continue:
        Next cell

'Setting colors for various repeated elements
    colorchoice = 3
    For Each cell In ActiveSheet.UsedRange
        If havecolors.Exists(cell.Text) = True Then GoTo Continue2
        If repeated.Exists(cell.Text) Then
            For Each cell2 In ActiveSheet.UsedRange()
                If cell2.Value = cell.Value Then cell2.Interior.ColorIndex = colorchoice
                On Error Resume Next
                havecolors.Add (cell.Text)
                On Error GoTo 0
            Next cell2
        End If
        If colorchoice < 56 Then colorchoice = colorchoice + 1 Else colorchoice = 2
Continue2:
    Next cell
End Sub