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

您可以决定定义该列的已使用范围并仅对其上色，而不是在一列中逐格进行操作，因此每列不超过一百万个单元格。

这可以通过以下方式完成：

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解决方案，则可以按格式搜索并处理相关单元格。这应该明显更快。

services.AddMvcCore().AddVersionedApiExplorer(
                opt =>
                {
                    opt.GroupNameFormat = "'v'VVV";

                    opt.SubstituteApiVersionInUrl = true;
                });

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

2 个答案: