excel 按重复项组突出显示具有不同颜色的行

vbkedwbf  于 2023-04-22  发布在  其他
关注(0)|答案(5)|浏览(162)

如何按重复项组突出显示不同颜色的行?
我不关心使用的颜色本身,我只希望重复的行是一种颜色,而下一组重复的行是另一种颜色。

例如,如果我想要“1”是绿色的,“2”是蓝色的,等等,在我的列中,它会上升到120。
谢谢大家。

ippsafx7

ippsafx71#

Gowtham的解决方案仅针对数字,并使用VBA。您可以使用以下解决方案,它适用于任何类型的数据,并且不需要VBA。
我们可以使用另一个列,它使用公式为所有重复项生成一个唯一值,并为该列使用**”Conditional FormattingColor Scales“**。

你可以使用的公式是

"=ROW(INDEX(A$2:A$12,MATCH(A2,A$2:A$12,0)))"

在上面的公式中,A$2:A$12是我们要搜索重复项的范围。
该公式基本上是在给定范围内搜索重复值的第一个示例,并输入该第一个示例的行号。

P.S:在上述公式中,范围“A$2:A$12”是固定范围,在表中使用上述公式要简单得多,因为表范围是动态的
使用Table的另一个好处是,我们甚至可以对数据进行排序,将重复的值分组在一起

=ROW(INDEX([Column1],MATCH(A2,[Column1],0)))
2cmtqfgy

2cmtqfgy2#

试试这个简单的代码,并根据你的需要修改它。

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

fykwrbwg

fykwrbwg3#

Gowtham的答案很棒,如果没有它们,我就不会想出下面的答案!我也需要唯一的颜色分配,但是,我需要比colorindex提供的56种颜色更多的变化,所以我稍微修改了Gowtham的代码,通过使用Randalong沿着RGB之间通过随机的红色,蓝色和绿色值创建随机的颜色来提供更多的变化。
我将颜色范围保持在120 - 255之间,因为一些较低的值可能会导致单元格太暗而无法阅读,但您可以根据自己的喜好进行定制。下面的代码当然可以改进,因为我不是Maven,但它能够获得所需的100多种颜色。
编辑:我会补充说,有一种可能性,RGB值可以重叠。我只是需要颜色编码的视觉援助;但是如果你需要严格的唯一颜色值,这个代码就不能保证了。

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
olqngx59

olqngx594#

我在https://www.extendoffice.com/documents/excel/3772-excel-highlight-duplicate-values-in-different-colors.html中找到了这个VBA:

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
z2acfund

z2acfund5#

找到了Excel VBA的这段代码,它可以用不同的颜色组织大量的重复项。

`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

相关问题