Excel 以 VBA 的颜色突出显示具有相同值的单元格

Question

Excel 用颜色突出显示具有相同值的单元格

我需要一个宏来为所有重复的单元格着色，

我需要给单元格涂上不同的颜色，单元格 A2 和单元格 A3 可以有相同的值，比如 50，单元格 A4 和 A5 可以有 60，单元格 A7、A8 和 A9 可以有值为 40，或者单元格 A11、A15 和 A20 的值为 250。

如果值不同，我需要颜色不相同，因此如果值重复，单元格 A2 和 A3 可以是黄色，然后单元格 A4 和 A5 可以是橙色，单元格 A7、A8 和 A9 可以是黄色.

问题是我可以有一个 Excel 个文件，从 10 个单元格到 600 个单元格，所以手动完成可能需要很长时间。

我有一个可以用这种方式着色的宏，但我需要能够读取彩色单元格中的值，这是我的宏无法做到的。

是否可以在 VBA 中做这样的事情？

VBA代码：

    Dim ws As Worksheet
    Dim clr As Long
    Dim rng As Range
    Dim cell As Range
    Dim r As Range
    
    Set ws = ThisWorkbook.Sheets(ActiveSheet.Name)
    Set rng = ws.Range("A2:a" & Range("A" & ws.Rows.Count).End(xlUp).Row)
    With rng
        Set r = .Cells(.Cells.Count)
    End With
    rng.Interior.ColorIndex = xlNone
    clr = 3
    For Each cell In rng
        If Application.WorksheetFunction.CountIf(rng, cell) > 1 Then
            'addresses will match for first instance of value in range
            If rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=r).Address = cell.Address Then
                'set the color for this value (will be used throughout the range)
                cell.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                'if not the first instance, set color to match the first instance
                cell.Interior.ColorIndex = rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=r).Interior.ColorIndex
            End If
        End If
    Next   
End Sub

Answer 1

如果您只想像图片那样使用交替颜色，只需将 clr = clr + 1 行更改为如下内容即可。

            If clr = 44 Then
               clr = 45
            Else
               clr = 44
            End If

这些是对图片颜色的估计。您还想将 clr = 3 更改为 clr = 44 或您使用的任何颜色。

Answer 2

如果数字按升序或降序排序（如您的图片所示），那么您可以比使用查找方法更快地完成此操作。

Option Explicit

Public Sub ColorDuplicatesAlternate()
    Dim ws As Worksheet  ' define your sheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Dim LastRow As Long  ' find last used row
    LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Dim DataRange As Range  ' read data range 
    Set DataRange = ws.Range("A1", "A" & LastRow + 1)
    
    Dim DataValues() As Variant  ' read data into array for fast processing
    DataValues = DataRange.Value
    
    Dim iStart As Long
    iStart = 1
    
    Dim BlockValue As Variant
    Dim IsEven As Boolean
    
    Dim EvenBlocks As Range
    Dim OddBlocks As Range
    Dim CurrentBlock As Range
    
    Dim iRow As Long
    For iRow = LBound(DataValues) + 1 To UBound(DataValues)  ' loop through all data and find blocks, collect them in even and odd numbered blocks for alternate coloring
        If BlockValue <> DataValues(iRow, 1) Then
            If iRow - iStart > 1 Then
                Set CurrentBlock = DataRange.Cells(iStart, 1).Resize(RowSize:=iRow - iStart)
                
                If IsEven Then
                    If EvenBlocks Is Nothing Then
                        Set EvenBlocks = CurrentBlock
                    Else
                        Set EvenBlocks = Union(EvenBlocks, CurrentBlock)
                    End If
                Else
                    If OddBlocks Is Nothing Then
                        Set OddBlocks = CurrentBlock
                    Else
                        Set OddBlocks = Union(OddBlocks, CurrentBlock)
                    End If
                End If
                IsEven = Not IsEven
            End If
            iStart = iRow
            BlockValue = DataValues(iRow, 1)
        End If
    Next iRow
    
    ' color all even and odd blocks alternating
    EvenBlocks.Interior.Color = vbRed
    OddBlocks.Interior.Color = vbGreen
End Sub

Excel 以 VBA 的颜色突出显示具有相同值的单元格

Excel highlight cells with the same value in colors with VBA

excel

vba

colors