如何优化VBA的UpdateSummary子程序以提升运行效率？

安全阿岳

2026-7-26

VBA汇总子程序性能优化问题

我的工作簿包含1个汇总工作表和若干估算工作表，UpdateSummary子程序通过手动更新按钮填充汇总表。多数数据位于已知固定单元格，部分数据在估算工作表的随机行中，我用fFindRowByCol函数查找这些行。现在这个子程序运行很慢，我知道这是用了“蛮力法”，想问是不是应该先把单元格值写入数组再粘贴到汇总表？或者有没有其他更优方案？

Sub UpdateSummary()
    Call ParaOff
    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
    Dim name As String
    j = 5
    Call HideX
    Call SortWorksheets
    If Not WorksheetExists(wsF) Then
        MsgBox "ERROR: Worksheet '" & wsF & "' is missing."
    Else
        'Sheets(wsF).Activate
        Worksheets(wsF).Range("B7:U41").ClearContents
        Worksheets(wsF).Range("W7:W41").ClearContents
        For i = 1 To Worksheets.Count
            If Worksheets(i).name <> wsF And Worksheets(i).name <> wsG And Worksheets(i).name <> wsI And Worksheets(i).name <> wsJ And Worksheets(i).name <> wsK Then
                Worksheets(i).Range("S1").Copy 'PROJECT
                Worksheets(wsF).Range("B" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("J6").Copy 'LOCATION
                Worksheets(wsF).Range("C" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("Q1").Copy 'DURATION
                Worksheets(wsF).Range("D" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("M1").Copy 'PROJECT TOTAL
                Worksheets(wsF).Range("E" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("S10").Copy 'MISC %
                Worksheets(wsF).Range("F" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("S11").Copy 'MISC $
                Worksheets(wsF).Range("G" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("N10").Copy 'OTHER %
                Worksheets(wsF).Range("H" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("N11").Copy 'OTHER $
                Worksheets(wsF).Range("I" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("P13").Copy 'GC TOTAL
                Worksheets(wsF).Range("J" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("K11").Copy 'GC %
                Worksheets(wsF).Range("K" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("L11").Copy 'GC DAY
                Worksheets(wsF).Range("L" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("M11").Copy 'GC MONTH
                Worksheets(wsF).Range("M" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("S14").Copy 'PM %
                Worksheets(wsF).Range("N" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("K14").Copy 'PM HRS
                Worksheets(wsF).Range("O" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("S16").Copy 'SUPER %
                Worksheets(wsF).Range("P" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("K16").Copy 'SUPER HRS
                Worksheets(wsF).Range("Q" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("S18").Copy 'PE %
                Worksheets(wsF).Range("R" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("K18").Copy 'PE HRS
                Worksheets(wsF).Range("S" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Worksheets(i).Range("Q10").Copy 'CARP HRS
                Worksheets(wsF).Range("T" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                x = fFindRowByCol(Worksheets(i).name, "I", "Div 26*")
                Worksheets(i).Range("P" & x).Copy 'DIV 26 $
                Worksheets(wsF).Range("U" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                x = fFindRowByCol(Worksheets(i).name, "I", "Div 32*")
                Worksheets(i).Range("P" & x).Copy 'DIV 32 $
                Worksheets(wsF).Range("W" & j + i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            End If
        Next i
    End If
    Call ParaOn
    Call Happy
End Sub

优化方案

1. 用数组替代逐单元格复制粘贴（核心优化）

你的判断完全正确，逐单元格Copy/PasteSpecial是性能瓶颈的主要来源——每次操作都要和Excel界面交互，开销极大。改用数组一次性读写能把交互次数从几十次降到1-2次，速度提升明显：

先统计需要处理的工作表数量，定义对应大小的二维数组；
遍历估算表时，直接把固定单元格的值赋值到数组对应位置；
最后把整个数组一次性写入汇总表。

示例片段：

' 先统计需要处理的工作表数量
Dim wsCount As Integer
wsCount = 0
For i = 1 To Worksheets.Count
    If Worksheets(i).Name <> wsF And Worksheets(i).Name <> wsG And Worksheets(i).Name <> wsI And Worksheets(i).Name <> wsJ And Worksheets(i).Name <> wsK Then
        wsCount = wsCount + 1
    End If
Next i

' 定义数组（行数=需要处理的表数，列数=汇总字段数）
Dim summaryArr As Variant
ReDim summaryArr(1 To wsCount, 1 To 21)

' 遍历填充数组
Dim rowIndex As Integer
rowIndex = 0
For i = 1 To Worksheets.Count
    If Worksheets(i).Name <> wsF And Worksheets(i).Name <> wsG And Worksheets(i).Name <> wsI And Worksheets(i).Name <> wsJ And Worksheets(i).Name <> wsK Then
        rowIndex = rowIndex + 1
        Dim ws As Worksheet
        Set ws = Worksheets(i)
        ' 直接赋值，避免复制粘贴
        summaryArr(rowIndex, 1) = ws.Range("S1").Value ' PROJECT
        summaryArr(rowIndex, 2) = ws.Range("J6").Value ' LOCATION
        summaryArr(rowIndex, 3) = ws.Range("Q1").Value ' DURATION
        ' ... 其他固定字段同理
        ' 处理查找的行
        x = fFindRowByCol(ws.Name, "I", "Div 26*")
        summaryArr(rowIndex, 20) = ws.Range("P" & x).Value ' DIV 26 $
        x = fFindRowByCol(ws.Name, "I", "Div 32*")
        summaryArr(rowIndex, 21) = ws.Range("P" & x).Value ' DIV 32 $
    End If
Next i

' 一次性写入汇总表的B-U列
Worksheets(wsF).Range("B7").Resize(wsCount, 20).Value = summaryArr
' 单独写入W列（因为中间跳过了V列）
For rowIndex = 1 To wsCount
    Worksheets(wsF).Range("W" & 6 + rowIndex).Value = summaryArr(rowIndex, 21)
Next rowIndex

2. 优化查找函数`fFindRowByCol`

如果fFindRowByCol是自行编写的循环查找，那也是性能黑洞——改用Excel内置的Range.Find方法，速度会快很多：

Function fFindRowByCol(wsName As String, colLetter As String, searchText As String) As Integer
    Dim ws As Worksheet
    Set ws = Worksheets(wsName)
    Dim foundCell As Range
    ' 按部分匹配查找目标文本
    Set foundCell = ws.Columns(colLetter).Find(What:=searchText, LookIn:=xlValues, LookAt:=xlPart)
    If Not foundCell Is Nothing Then
        fFindRowByCol = foundCell.Row
    Else
        fFindRowByCol = 0 ' 没找到返回0，可根据需求调整
    End If
End Function

如果必须用循环，建议只遍历工作表的已使用行（ws.UsedRange.Rows.Count），而非整个列，减少循环次数。

3. 其他细节优化

强化Excel特性禁用：除了ParaOff里的ScreenUpdating和EnableEvents，可以加上Application.Calculation = xlCalculationManual，子程序结束后再改回xlCalculationAutomatic，避免不必要的自动计算；
减少重复工作表引用：遍历的时候把当前工作表赋值给变量（比如Set ws = Worksheets(i)），避免重复调用Worksheets(i)；
简化工作表判断逻辑：把不需要处理的表名放进集合，判断当前表是否在集合内，代码更简洁：

Dim excludedSheets As New Collection
excludedSheets.Add wsF
excludedSheets.Add wsG
excludedSheets.Add wsI
excludedSheets.Add wsJ
excludedSheets.Add wsK

' 遍历判断
On Error Resume Next
excludedSheets.Add Worksheets(i).Name
If Err.Number <> 0 Then
    ' 表在排除列表，跳过
    On Error GoTo 0
Else
    ' 处理当前表
    excludedSheets.Remove Worksheets(i).Name
    On Error GoTo 0
    ' ... 执行数据读取逻辑
End If

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

如何优化VBA的UpdateSummary子程序以提升运行效率？

1. 用数组替代逐单元格复制粘贴（核心优化） #

2. 优化查找函数fFindRowByCol #

3. 其他细节优化 #

1. 用数组替代逐单元格复制粘贴（核心优化）

2. 优化查找函数`fFindRowByCol`

3. 其他细节优化