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

Question

我正在尝试突出显示某个范围内的所有重复项。不同之处在于我希望每个不同的值都有不同的颜色。例如，所有值 "Apple" 都是一种颜色。所有值 "Car" 将是另一种颜色等。我找到了一种方法来执行此操作，尽管它只能在一个列上为运行。我需要一些帮助才能在多列上达到运行。这是我的例子的照片：

这是我运行ning 的 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

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

旁注： 我也在寻找一些方法来避免 return 当范围内的单元格为空时出现错误。这不是重点，但如果有人对此有答案，也很乐意听到。

Answer 1

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

我会创建一个 class（插入 class 模块并将其名称更改为 cls）。转到 VBA 中的参考并检查 Microsoft 脚本运行时。这是导入库以与 VBA.

一起使用

在 class 模块中粘贴 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

Answer 2

我采用的方法是将范围内的所有值排序到字典中，记录所有单元格相对于单元格值的地址。所以，我得到一个列表，如 "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" 的位置设置工作表的名称。您还可以通过修改代码顶部的常量值来调整工作范围。

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

Assign different colors to different duplicate values in a range

excel

vba

conditional-formatting

duplicates