将不同的颜色分配给一个范围内的不同重复值（Excel VBA）

Question

我正在尝试突出显示范围内的所有重复项。我想让每个不同的值都有不同的颜色。例如，所有值“ Apple”将是一种颜色。所有的值“ Car”将是另一种颜色，等等。尽管只能在一个Column上运行，但我找到了一种实现方法。我需要一些帮助使其在多列上运行。这是我的示例照片：

这里是我正在运行的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

[如果有人能让我知道如何覆盖各种列和行，将不胜感激！

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

Answer 1

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

我将创建一个类（插入类模块并将其名称更改为cls）。转到VBA中的“引用”，然后检查“ Microsoft脚本运行时”。这是导入库以与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 = 2
    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