根据值更快地更改单元格颜色

debugcn 发表于 Dev

金斯利-詹姆斯

我有 vba 代码可以根据它的内容更改单元格的颜色，目前我正在使用为循环和选择 case 语句索引的行和列分别循环遍历 13000 个单元格，但它需要大约 30 秒。有谁知道更快的方法？

安比

我怀疑从单元格中读取每个值占用了大量时间。尝试将数据读入数组，然后创建 15 个范围，每种颜色一个。然后，您只需在最后用适当的颜色填充每个范围。

话虽如此，对 13,000 个细胞进行着色需要一些时间。我不能超过 10 秒。如果你只需要做一次，30 秒似乎还不错？

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

本文收集自互联网，转载请注明来源。

如有侵权，请联系[email protected] 删除。