将一个范围内的不同颜色分配给不同的重复值 [英] Assign different colors to different duplicate values in a range

问题描述

我正在尝试突出显示范围内的所有重复项.难点是我希望每个不同的值都具有不同的颜色.例如，所有值"Apple"将是一种颜色.所有的值"Car"将是另一种颜色，等等.尽管只能在一个Column上运行，但我找到了一种方法来执行此操作.我需要一些帮助使其在多列上运行.这是我的示例照片:

I'm trying to have all duplicates in a range highlighted. The twist is I want each different value to have a different color. For example all the values "Apple" would be one color. All the values "Car" would be another color etc. I've found a way to do this, although it can only be run on one Column. I need some help getting it to run on multiple columns. Here is a photo of my example:

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

Here is the VBA code I'm running which currently highlights only column 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

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

If anyone could let me know how to have this cover a range of various columns and rows that would be greatly appreciated!

侧面说明::我也在寻找某种方法，以使当范围中的单元格为空时不返回错误.这不是重点，但是如果有人对此有答案，也会很高兴听到.

Side Note: I'm also looking for some way to not return an error when a cell in the range is empty. Not the main point of this but if someone has an answer for that would be happy to hear it as well.

推荐答案

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

The approach I took is to sort all values in the range into a dictionary, recording the addresses of all cells relative to the cell values. So, I get a list like "B2" occurs in C20, E25, AG90. In the next step a different color is applied to each value. You can prepare as many colors as you have the patience to set up but if there aren't enough the macro will restart from the first color after it has applied the last available.

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"的位置.您还可以通过修改代码顶部的常量值来调整工作范围.

Be sure to set the name of your worksheet where it's presently shown as "Sheet1". You can also adjust the working range by modifying the values of the constants at the top of the code.

这篇关于将一个范围内的不同颜色分配给不同的重复值的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！