问题
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:
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.
回答1:
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
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.
回答2:
I am sorry for not a very elegant solution. I would use a set (probably a dictionary would be even better here). A set is a data structure which takes a particular value only once. So if a certain cell contents appeared already somewhere else, a set will let me know that I am trying to add to it an element which has been already added to the set. In this way I can easily see that this element is a repetition. A wrapper in the class module is to make an easy use of an additional Ms library elements with various data structures.
I would create a class (insert class module and change its name to cls). Go to References in VBA and check Microsoft Scripting Runtime. This is importing the library to work with VBA.
In the class module paste the wrapper for 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
And in a normal VBA module paste the code which firstly adds to a set all new elements which it found in non-empty cells and later it colors them. Firstly we go through all non-empty cells and add their contents to the set allElements. At the same time all new elements we add to the set called repeated.
In the second part of the code we go once again through all non-empty cells and if their contents belongs to the set repeated, we will change their color. But we have to set the same color for all other cells with the same contents and therefore, we use a nested loop. All the cells with a particular contents get the same color. After changing their color we add their contents to yet another set - colored so we will not change their color again.
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
来源：https://stackoverflow.com/questions/62366723/assign-different-colors-to-different-duplicate-values-in-a-range