使用VBA高效统计彩色单元格的优化方案

我有一个工作表，活动区域为A4:DD2500，共270000个单元格。通过@EvilBlueMonkey提供的代码，可根据A列下拉选择，将每行B至DD列单元格设置为蓝色、灰色或黄色底色；蓝色单元格输入内容后，会通过条件格式变为绿色以标记完成。

我需要实现一段可在用户每次输入后动态运行的代码，统计四种场景：

• 蓝色单元格
• 绿色单元格
• 无内容黄色单元格
• 有内容黄色单元格

我编写的代码可运行但每次都会导致Excel冻结，请问有没有更高效的方式遍历270000个单元格？或者能否仅遍历A列已填充内容的行？

原代码如下：

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    'Declarations.
    Dim CountRange As Range
    Dim CountRangeCell As Range
    Dim BColorCounter As Long
    Dim GColorCounter As Long
    Dim YColorCounter As Long
    Dim YColorTextCounter As Long
        
    'SETTINGS:
    
    'Set Cells to be counted Range
    Set CountRange = Worksheets("ADIS").Range("B3:DD2500")
      
        'Loop through each cell in the range
        For Each CountRangeCell In CountRange
         'Checking Blue Color
        If Cells(CountRangeCell.Row, CountRangeCell.Column).DisplayFormat.Interior.Color = RGB(155, 194, 230) Then
        BColorCounter = BColorCounter + 1
        Else
               
        'Checking Yellow Color
        If Cells(CountRangeCell.Row, CountRangeCell.Column).DisplayFormat.Interior.Color = RGB(255, 255, 0) And CountRangeCell.Text = "" Then
        YColorCounter = YColorCounter + 1
        Else
       
        'Checking Green Color
        If Cells(CountRangeCell.Row, CountRangeCell.Column).DisplayFormat.Interior.Color = RGB(169, 208, 142) Then
        GColorCounter = GColorCounter + 1
        Else
        
        'Checking Yellow With Text
        If Cells(CountRangeCell.Row, CountRangeCell.Column).DisplayFormat.Interior.Color = RGB(255, 255, 0) And CountRangeCell.Value <> "" Then
        YColorTextCounter = YColorTextCounter + 1
           
        End If
        End If
        End If
        End If
        
        Next
        Range("C2504") = YColorCounter
        Range("D2504") = BColorCounter
        Range("E2504") = GColorCounter
        Range("F2504") = YColorTextCounter

End Sub

核心优化方向 #

1. 缩小遍历范围：只统计A列有内容的行对应的B:DD区域，跳过空行减少无效遍历
2. 减少对象交互：直接使用遍历对象cell而非重复调用Cells(...)，降低Excel对象模型访问开销
3. 调整触发时机：用Worksheet_Change替代Worksheet_SelectionChange，仅在用户输入内容时触发统计，避免无意义的重复运行
4. 临时关闭系统特性：运行时关闭屏幕刷新和事件触发，大幅提升代码执行速度

优化后的代码 #

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dataRange As Range
    Dim cell As Range
    Dim BColorCounter As Long, GColorCounter As Long
    Dim YColorCounter As Long, YColorTextCounter As Long
    Dim cellColor As Long, cellValue As Variant
    
    Set ws = Me ' 绑定当前工作表，避免硬编码表名
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' 获取A列最后一行有内容的行号
    
    ' 处理A列无有效内容的情况
    If lastRow < 4 Then
        ws.Range("C2504:F2504").Value = Array(0, 0, 0, 0)
        Exit Sub
    End If
    
    ' 锁定需要统计的范围：B4到DD列对应A列有内容的最后一行
    Set dataRange = ws.Range("B4:DD" & lastRow)
    
    ' 关闭屏幕刷新和事件触发，提升执行效率
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 初始化计数器
    BColorCounter = 0
    GColorCounter = 0
    YColorCounter = 0
    YColorTextCounter = 0
    
    ' 遍历目标区域，按颜色分类统计
    For Each cell In dataRange
        cellColor = cell.DisplayFormat.Interior.Color
        cellValue = cell.Value
        
        Select Case cellColor
            Case RGB(155, 194, 230) ' 蓝色单元格
                BColorCounter = BColorCounter + 1
            Case RGB(169, 208, 142) ' 绿色单元格
                GColorCounter = GColorCounter + 1
            Case RGB(255, 255, 0) ' 黄色单元格，区分有无内容
                If cellValue = "" Then
                    YColorCounter = YColorCounter + 1
                Else
                    YColorTextCounter = YColorTextCounter + 1
                End If
            ' 灰色单元格无需统计，直接跳过
        End Select
    Next cell
    
    ' 写入统计结果
    ws.Range("C2504").Value = YColorCounter
    ws.Range("D2504").Value = BColorCounter
    ws.Range("E2504").Value = GColorCounter
    ws.Range("F2504").Value = YColorTextCounter
    
    ' 恢复系统设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

额外优化建议 #

• 纯公式统计方案：若无需VBA，可结合COUNTIFS和定义名称调用GET.CELL函数实现无代码统计，完全避免遍历开销
• 缓存格式数据：在A列下拉选择时预先缓存每行的底色信息，后续统计直接读取缓存，不用反复调用DisplayFormat
• 进一步缩小行内范围：如果每行的B:DD并非全部有底色，可针对每行获取最后一个有格式的单元格，减少单行列数遍历

内容的提问来源于stack exchange，提问作者Gregg Rosenstein