Dim r As Long, c As Long, i As Long, rOff As Long, cOff As Long
Dim data As Variant
Dim dataRange As Range, cell As Range
Dim colourRanges(14) As Range
Dim colours(14) As Long

'Define the colours
colours(0) = 255
colours(1) = 65535
colours(2) = 5296274
colours(3) = 12611584
colours(4) = 10498160
colours(5) = 49407
colours(6) = 192
colours(7) = 5287936
colours(8) = 15773696
colours(9) = 6299648
colours(10) = 5540756
colours(11) = 9803737
colours(12) = 13083058
colours(13) = 9486586
colours(14) = 14474738

'Define the target range
With Sheet1
    Set dataRange = .Range(.Range("A2"), _
                           .Cells(.Rows.Count, "A").End(xlUp)) _
                    .Resize(, 103)
End With

'Calculate offsets from "A1"
With dataRange
    rOff = .Cells(1).Row - 1
    cOff = .Cells(1).Column - 1
End With

'Read data
data = dataRange.Value2


'Test the data
For r = 1 To UBound(data, 1)
    For c = 1 To UBound(data, 2)
        Select Case data(r, c)
            Case 1: i = 0
            Case 2: i = 1
            Case 3: i = 2
            Case 4: i = 3
            Case 5: i = 4
            Case 6: i = 5
            Case 7: i = 6
            Case 8: i = 7
            Case 9: i = 8
            Case 10: i = 9
            Case 11: i = 10
            Case 12: i = 11
            Case 13: i = 12
            Case 14: i = 13
            Case 15: i = 14
            Case Else: i = -1
        End Select

        'Build the colour ranges
        If i <> -1 Then
            With Sheet1
                Set cell = .Cells(r + rOff, c + cOff)
                If colourRanges(i) Is Nothing Then
                    Set colourRanges(i) = cell
                Else
                    Set colourRanges(i) = Union(colourRanges(i), cell)
                End If
            End With
        End If
    Next
Next

'Colour the ranges
Application.ScreenUpdating = False
For i = 0 To 14
    colourRanges(i).Interior.Color = colours(i)
Next
Application.ScreenUpdating = True

票数 1

Stack Overflow用户

发布于 2017-07-09 05:29:39

这是我从另一个问题中得到的一些示例代码。您应该能够看到设置autofilter是多么容易，一旦它根据您的标准进行筛选，只需为您想要为可见单元格设置的任何颜色执行interior.colorindex，然后更改下一个颜色的标准，漂洗并重复。我还建议在子集计算开始时将计算改为手动，同时屏幕更新为假，并启用事件假，然后在子集计算结束时将计算恢复为自动，并再次使其他两件事为真。

Private Sub CommandButton2_Click()
Dim IMBacklogSh As Worksheet, logoffSh As Worksheet, deniedsh As Worksheet

Set IMBacklogSh = ThisWorkbook.Worksheets("Backlog")
Set logoffSh = ThisWorkbook.Worksheets("Claims Logged off")
Set deniedsh = ThisWorkbook.Worksheets("Claims Denied")

With IMBacklogSh
    If .AutoFilterMode Then .AutoFilterMode = False
    With .Cells(1, 1).CurrentRegion
        .AutoFilter field:=13, Criteria1:="#N/A"
        .AutoFilter field:=14, Criteria1:="C"
        With .Resize(.Rows.Count - 1, Columns.Count).Offset(1, 0)
            If CBool(Application.Subtotal(103, .Cells)) Then
                .Copy Destination:= _
                    logoffSh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                'optionally delete the originals
                .EntireRow.Delete
            End If
        End With
        .AutoFilter field:=14, Criteria1:="<>C"
        With .Resize(.Rows.Count - 1, Columns.Count).Offset(1, 0)
            If CBool(Application.Subtotal(103, .Cells)) Then
                .Copy Destination:= _
                    deniedsh.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
                'optionally delete the originals
                .EntireRow.Delete
            End If
        End With
    End With
    If .AutoFilterMode Then .AutoFilterMode = False
End With