Sub dupColors()
Dim i As Long, cIndex As Long
cIndex = 3
Cells(1, 1).Interior.ColorIndex = cIndex
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Cells(i, 1) = Cells(i + 1, 1) Then
Cells(i + 1, 1).Interior.ColorIndex = cIndex
Else
If Cells(i + 1, 1) <> "" Then
cIndex = cIndex + 1
Cells(i + 1, 1).Interior.ColorIndex = cIndex
End If
End If
Next i
End Sub
Dim rCount, RandCol1, RandCol2, RandCol3, i As Long
rCount = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To rCount
If Sheet1.Cells(i, 1) = Sheet1.Cells(i + 1, 1) Then
Sheet1.Cells(i + 1, 1).Interior.Color = RGB(RandCol1, RandCol2, RandCol3)
Else
If Sheet1.Cells(i + 1, 1) <> "" Then
RandCol1 = WorksheetFunction.RandBetween(120, 255)
RandCol2 = WorksheetFunction.RandBetween(120, 255)
RandCol3 = WorksheetFunction.RandBetween(120, 255)
Sheet1.Cells(i + 1, 1).Interior.Color = RGB(RandCol1, RandCol2, RandCol3)
End If
End If
Next i
Sub ColorCompanyDuplicates()
'Updateby Extendoffice
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
Next
End Sub
`Sub ColorCompanyDuplicates()
'Updateby Extendoffice 20171222
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Range("M10:P10010")
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
If xCell.Value <> "" Then
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.Color = RGB(xRed, xGreen, xBlue)
xCell.Interior.Color = xCellPre.Interior.Color
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
xRed = Application.WorksheetFunction.RandBetween(0, 255)
xGreen = Application.WorksheetFunction.RandBetween(0, 255)
xBlue = Application.WorksheetFunction.RandBetween(0, 255)
On Error GoTo 0
End If
Next
End Sub
5条答案
按热度按时间ippsafx71#
Gowtham的解决方案仅针对数字,并使用VBA。您可以使用以下解决方案,它适用于任何类型的数据,并且不需要VBA。
我们可以使用另一个列,它使用公式为所有重复项生成一个唯一值,并为该列使用**”
Conditional Formatting
〉Color Scales
“**。你可以使用的公式是
在上面的公式中,A$2:A$12是我们要搜索重复项的范围。
该公式基本上是在给定范围内搜索重复值的第一个示例,并输入该第一个示例的行号。
P.S:在上述公式中,范围“A$2:A$12”是固定范围,在表中使用上述公式要简单得多,因为表范围是动态的
使用Table的另一个好处是,我们甚至可以对数据进行排序,将重复的值分组在一起
2cmtqfgy2#
试试这个简单的代码,并根据你的需要修改它。
fykwrbwg3#
Gowtham的答案很棒,如果没有它们,我就不会想出下面的答案!我也需要唯一的颜色分配,但是,我需要比colorindex提供的56种颜色更多的变化,所以我稍微修改了Gowtham的代码,通过使用Randalong沿着RGB之间通过随机的红色,蓝色和绿色值创建随机的颜色来提供更多的变化。
我将颜色范围保持在120 - 255之间,因为一些较低的值可能会导致单元格太暗而无法阅读,但您可以根据自己的喜好进行定制。下面的代码当然可以改进,因为我不是Maven,但它能够获得所需的100多种颜色。
编辑:我会补充说,有一种可能性,RGB值可以重叠。我只是需要颜色编码的视觉援助;但是如果你需要严格的唯一颜色值,这个代码就不能保证了。
olqngx594#
我在https://www.extendoffice.com/documents/excel/3772-excel-highlight-duplicate-values-in-different-colors.html中找到了这个VBA:
z2acfund5#
找到了Excel VBA的这段代码,它可以用不同的颜色组织大量的重复项。