Excel VBA - 为大量单元格着色的有效方法

Question

我正在编写一段代码，该代码根据单元格的可能值为单元格的背景和字体值着色。我编写的代码运行良好，但速度很慢，因为我要处理大量单元格（大约 10 * 150k 单元格）。

Private Sub ApplyQtlColor(ByRef ws As Worksheet, ByVal qtlColumns As String)

Dim cell As Range

For Each cell In ws.Range(qtlColumns).Cells
    Select Case cell.value

        Case 1
            cell.Interior.Color = RGB(0, 106, 130)
            cell.Font.Color = RGB(255, 255, 255)
        Case 2
            cell.Interior.Color = RGB(0, 138, 170)
            cell.Font.Color = RGB(255, 255, 255)
        Case 3
            cell.Interior.Color = RGB(177, 209, 217)
            cell.Font.Color = RGB(0, 0, 0)
        Case 4
            cell.Interior.Color = RGB(204, 225, 230)
            cell.Font.Color = RGB(0, 0, 0)

    End Select
Next cell

End Sub

为了改进程序，我想加快功能。

我得到的唯一想法是，我可以获取变量中的值，循环进入变量以获取值的相应行，并在定义范围内的一行（对于一种情况）中应用颜色。但是关于单元格的数量，定义范围似乎有点复杂（我还没有尝试过）。

所以我想知道是否有人遇到过同样的情况并找到了解决方案。

非常感谢！

Answer 1

您可以决定定义该列的使用范围并仅对其着色，而不是在一列中逐个单元格，即每列超过 100 万个单元格。

这是可以做到的：

Private Sub ApplyQtlColor(ByRef ws As Worksheet, ByVal qtlColumns As String)

    Dim myRange As Range
    Set myRange = ws.Range(qtlColumns)

    Dim i As Long
    Dim foundRange As Range
    For i = 1 To 4
        Set foundRange = FindAll(myRange, i)
        If Not foundRange Is Nothing Then
            'foundRange.Interior.Color = PickInteriorColor(i)
            foundRange.Font.Color = PickFontColor(i)
        End If
    Next i

End Sub

您可以通过某种函数来 PickFontColor 和 InteriorColor：

Public Function PickFontColor(i) As Long

    Select Case i
        Case 1
            PickFontColor = RGB(255, 255, 255)
        Case 2
            PickFontColor = RGB(255, 255, 255)
        Case Else
            PickFontColor = RGB(0, 0, 0)
    End Select

End Function

整个代码是这样调用的：ApplyQtlColor ActiveSheet, "C:E"

代码使用FindAll() 函数from CPearson。因此，在某处添加此函数：

Function FindAll(SearchRange As Range, _
                 FindWhat As Variant, _
                 Optional LookIn As XlFindLookIn = xlValues, _
                 Optional LookAt As XlLookAt = xlWhole, _
                 Optional SearchOrder As XlSearchOrder = xlByRows, _
                 Optional MatchCase As Boolean = False, _
                 Optional BeginsWith As String = vbNullString, _
                 Optional EndsWith As String = vbNullString, _
                 Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range

    Dim FoundCell As Range
    Dim FirstFound As Range
    Dim LastCell As Range
    Dim ResultRange As Range
    Dim XLookAt As XlLookAt
    Dim Include As Boolean
    Dim CompMode As VbCompareMethod
    Dim Area As Range
    Dim MaxRow As Long
    Dim MaxCol As Long
    Dim BeginB As Boolean
    Dim EndB As Boolean    

    CompMode = BeginEndCompare
    If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
        XLookAt = xlPart
    Else
        XLookAt = LookAt
    End If

    For Each Area In SearchRange.Areas
        With Area
            If .Cells(.Cells.Count).Row > MaxRow Then
                MaxRow = .Cells(.Cells.Count).Row
            End If
            If .Cells(.Cells.Count).Column > MaxCol Then
                MaxCol = .Cells(.Cells.Count).Column
            End If
        End With
    Next Area
    Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)

    On Error GoTo 0
    Set FoundCell = SearchRange.Find(what:=FindWhat, _
                                     after:=LastCell, _
                                     LookIn:=LookIn, _
                                     LookAt:=XLookAt, _
                                     SearchOrder:=SearchOrder, _
                                     MatchCase:=MatchCase)

    If Not FoundCell Is Nothing Then
        Set FirstFound = FoundCell
        Do Until False    ' Loop forever. We'll "Exit Do" when necessary.
            Include = False
            If BeginsWith = vbNullString And EndsWith = vbNullString Then
                Include = True
            Else
                If BeginsWith <> vbNullString Then
                    If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
                If EndsWith <> vbNullString Then
                    If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
            End If
            If Include = True Then
                If ResultRange Is Nothing Then
                    Set ResultRange = FoundCell
                Else
                    Set ResultRange = Application.Union(ResultRange, FoundCell)
                End If
            End If
            Set FoundCell = SearchRange.FindNext(after:=FoundCell)
            If (FoundCell Is Nothing) Then
                Exit Do
            End If
            If (FoundCell.Address = FirstFound.Address) Then
                Exit Do
            End If

        Loop
    End If

    Set FindAll = ResultRange

End Function

Answer 2

如果您需要 VBA 解决方案，则可以按格式搜索并处理相关单元格。这应该会快得多。

Sub FindFormatting()

    Dim Found As Range

    Application.FindFormat.Clear

    Application.FindFormat.Interior.Color = RGB(0, 106, 130)
    Set Found = FindAll(What:="", SearchWhat:=ActiveSheet, LookIn:=xlFormulas, LookAt:=xlPart, SearchFormat:=True)
    If Not Found Is Nothing Then Found.Font.Color = RGB(255, 255, 255)

    Application.FindFormat.Interior.Color = RGB(0, 138, 170)
    Set Found = FindAll(What:="", SearchWhat:=ActiveSheet, LookIn:=xlFormulas, LookAt:=xlPart, SearchFormat:=True)
    If Not Found Is Nothing Then Found.Font.Color = RGB(255, 255, 255)

    Application.FindFormat.Interior.Color = RGB(177, 209, 217)
    Set Found = FindAll(What:="", SearchWhat:=ActiveSheet, LookIn:=xlFormulas, LookAt:=xlPart, SearchFormat:=True)
    If Not Found Is Nothing Then Found.Font.Color = RGB(0, 0, 0)

    Application.FindFormat.Interior.Color = RGB(204, 225, 230)
    Set Found = FindAll(What:="", SearchWhat:=ActiveSheet, LookIn:=xlFormulas, LookAt:=xlPart, SearchFormat:=True)
    If Not Found Is Nothing Then Found.Font.Color = RGB(0, 0, 0)

End Sub

Function FindAll(What, _
    Optional SearchWhat As Variant, _
    Optional LookIn, _
    Optional LookAt, _
    Optional SearchOrder, _
    Optional SearchDirection As XlSearchDirection = xlNext, _
    Optional MatchCase As Boolean = False, _
    Optional MatchByte, _
    Optional SearchFormat) As Range

    'LookIn can be xlValues or xlFormulas, _
     LookAt can be xlWhole or xlPart, _
     SearchOrder can be xlByRows or xlByColumns, _
     SearchDirection can be xlNext, xlPrevious, _
     MatchCase, MatchByte, and SearchFormat can be True or False. _
     Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
     object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""

    Dim SrcRange As Range
    If IsMissing(SearchWhat) Then
        Set SrcRange = ActiveSheet.UsedRange
    ElseIf TypeOf SearchWhat Is Range Then
        Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
    ElseIf TypeOf SearchWhat Is Worksheet Then
        Set SrcRange = SearchWhat.UsedRange
    Else: SrcRange = ActiveSheet.UsedRange
    End If
    If SrcRange Is Nothing Then Exit Function

    'get the first matching cell in the range first
    With SrcRange.Areas(SrcRange.Areas.Count)
        Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
    End With

    Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)

    If Not CurrRange Is Nothing Then
        Set FindAll = CurrRange
        Do
            Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
            SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
            If CurrRange Is Nothing Then Exit Do
            If Application.Intersect(FindAll, CurrRange) Is Nothing Then
                Set FindAll = Application.Union(FindAll, CurrRange)
            Else: Exit Do
            End If
        Loop
    End If
End Function