VBA脚本运行缓慢求优化：交易编码解析与数据合并场景

原代码性能瓶颈分析 #

原脚本运行缓慢的核心原因包括：

• 逐单元格读写操作：这是VBA中最耗时的操作之一，大量循环写入单元格会导致Excel频繁刷新
• 使用Collection做映射查询：Collection的键查找效率远低于Dictionary
• 逐行移动数据：循环复制删除行的操作会触发多次工作表刷新
• 未禁用Excel的屏幕更新、自动计算等功能：这些后台操作会拖慢脚本运行速度

优化后的完整代码 #

Sub InterpretCodeAndCombineData()
    ' 关闭Excel耗时功能，提升运行速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim code As String
    Dim budgetItem As String
    Dim costCenter As String
    Dim budgetCategory As String
    Dim department As String
    Dim dataArr As Variant ' 用于批量读写的数组
    
    ' 使用Dictionary替代Collection，提升查找效率
    Dim costCenterMap As Object
    Set costCenterMap = CreateObject("Scripting.Dictionary")
    ' 填充成本中心映射（键为编码，值为名称）
    costCenterMap("CCF101") = "Biophotonics"
    costCenterMap("CCF102") = "Optics & Photonics"
    costCenterMap("CCF103") = "Electronics"
    costCenterMap("CCF104") = "System integration"
    costCenterMap("CCF105") = "Biomedical"
    costCenterMap("CCF106") = "R&D initiatives"
    costCenterMap("CCF107") = "SMLE"
    costCenterMap("CCF108") = "Quality"
    costCenterMap("CCF109") = "Supply chain & manufacturing"
    costCenterMap("CCF201") = "Finance"
    costCenterMap("CCF202") = "Legal"
    costCenterMap("CCF203") = "HR"
    
    Dim budgetCategoryMap As Object
    Set budgetCategoryMap = CreateObject("Scripting.Dictionary")
    ' 填充预算类别映射
    budgetCategoryMap("BC001") = "External services"
    budgetCategoryMap("BC002") = "Travel"
    budgetCategoryMap("BC003") = "Consumables"
    budgetCategoryMap("BC004") = "Equipment (non-IT)"
    budgetCategoryMap("BC005") = "IT Equipment"
    budgetCategoryMap("BC006") = "Software"
    budgetCategoryMap("BC007") = "Infrastructure"
    budgetCategoryMap("BC008") = "Training & team building"
    budgetCategoryMap("BC998") = "Personnel"
    budgetCategoryMap("BC999") = "Other"
    
    Dim budgetItemMap As Object
    Set budgetItemMap = CreateObject("Scripting.Dictionary")
    ' 填充预算项映射
    budgetItemMap("BI001") = "Salaries"
    budgetItemMap("BI002") = "Accounting"
    budgetItemMap("BI003") = "Audit"
    budgetItemMap("BI004") = "Legal"
    budgetItemMap("BI005") = "Certifications"
    budgetItemMap("BI006") = "Clinical trial"
    budgetItemMap("BI007") = "Contractors"
    budgetItemMap("BI999") = "Other"
  
    ' 需要处理的工作表列表
    Dim sheetNames As Variant
    sheetNames = Array("Revolut", "Abacus", "Budget")
    
    ' 循环处理每个工作表
    For Each sheetName In sheetNames
        Set ws = ThisWorkbook.Sheets(sheetName)
        lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
        
        ' 将数据批量读入数组，减少单元格交互
        dataArr = ws.Range("B2:F" & lastRow).Value
        
        ' 循环处理数组中的数据
        For i = LBound(dataArr, 1) To UBound(dataArr, 1)
            code = Trim(dataArr(i, 1))
            
            If Len(code) > 0 And InStr(code, "-") > 0 Then
                Dim parts() As String
                parts = Split(code, "-")
                
                If UBound(parts) = 2 Then
                    ' 统一转为大写，避免大小写问题
                    parts(0) = UCase(Trim(parts(0)))
                    parts(1) = UCase(Trim(parts(1)))
                    parts(2) = UCase(Trim(parts(2)))
                    
                    ' 从Dictionary中查找映射
                    costCenter = IIf(costCenterMap.Exists(parts(0)), costCenterMap(parts(0)), "Unknown Cost Center")
                    budgetCategory = IIf(budgetCategoryMap.Exists(parts(1)), budgetCategoryMap(parts(1)), "Unknown Category")
                    budgetItem = IIf(budgetItemMap.Exists(parts(2)), budgetItemMap(parts(2)), "Unknown Item")
                    
                    ' 分配部门
                    Select Case costCenter
                        Case "Biophotonics", "Optics & Photonics", "Electronics"
                            department = "R&D"
                        Case "Finance", "Legal", "HR"
                            department = "S&O"
                        Case Else
                            department = "Unknown Department"
                    End Select
                    
                    ' 将结果写入数组
                    dataArr(i, 2) = budgetItem
                    dataArr(i, 3) = budgetCategory
                    dataArr(i, 4) = costCenter
                    dataArr(i, 5) = department
                Else
                    ' 编码格式错误
                    dataArr(i, 2) = "Invalid Code"
                    dataArr(i, 3) = "Invalid Code"
                    dataArr(i, 4) = "Invalid Code"
                    dataArr(i, 5) = "Invalid Code"
                End If
            Else
                ' 无效编码
                dataArr(i, 2) = "Invalid Code"
                dataArr(i, 3) = "Invalid Code"
                dataArr(i, 4) = "Invalid Code"
                dataArr(i, 5) = "Invalid Code"
            End If
        Next i
        
        ' 将数组批量写入工作表，仅一次单元格交互
        ws.Range("B2:F" & lastRow).Value = dataArr
    Next sheetName
    
    ' 合并Revolut和Abacus数据到Combined工作表
    Dim wsRevolut As Worksheet, wsAbacus As Worksheet, wsCombined As Worksheet
    Dim lastRowRevolut As Long, lastRowAbacus As Long, lastRowCombined As Long
    
    Set wsRevolut = ThisWorkbook.Sheets("Revolut")
    Set wsAbacus = ThisWorkbook.Sheets("Abacus")
    Set wsCombined = ThisWorkbook.Sheets("Combined")
    
    ' 清空Combined工作表
    wsCombined.Cells.Clear
    
    ' 复制表头
    wsRevolut.Rows(1).Copy wsCombined.Rows(1)
    
    ' 获取数据行号
    lastRowRevolut = wsRevolut.Cells(wsRevolut.Rows.Count, "A").End(xlUp).Row
    lastRowAbacus = wsAbacus.Cells(wsAbacus.Rows.Count, "A").End(xlUp).Row
    
    ' 批量复制数据，避免逐行操作
    If lastRowRevolut >= 2 Then
        wsRevolut.Range("A2:" & wsRevolut.Cells(lastRowRevolut, wsRevolut.Columns.Count).End(xlToLeft).Address).Copy _
            wsCombined.Cells(2, 1)
    End If
    
    lastRowCombined = wsCombined.Cells(wsCombined.Rows.Count, "A").End(xlUp).Row
    If lastRowAbacus >= 2 Then
        wsAbacus.Range("A2:" & wsAbacus.Cells(lastRowAbacus, wsAbacus.Columns.Count).End(xlToLeft).Address).Copy _
            wsCombined.Cells(lastRowCombined + 1, 1)
    End If
    
    ' 将Personnel类别的数据移动到Personnel工作表
    Dim wsPersonnel As Worksheet, rngPersonnel As Range
    On Error Resume Next
    Set wsPersonnel = ThisWorkbook.Sheets("Personnel")
    If wsPersonnel Is Nothing Then
        Set wsPersonnel = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsPersonnel.Name = "Personnel"
        ' 复制表头
        wsCombined.Rows(1).Copy wsPersonnel.Rows(1)
    End If
    On Error GoTo 0
    
    ' 筛选出Personnel数据，批量移动
    lastRowCombined = wsCombined.Cells(wsCombined.Rows.Count, "A").End(xlUp).Row
    With wsCombined.Range("A1:F" & lastRowCombined)
        ' 清除原有筛选
        .AutoFilter
        ' 筛选预算类别为Personnel的行（第4列）
        .AutoFilter Field:=4, Criteria1:="Personnel"
        
        ' 获取筛选后的可见数据区域（排除表头）
        On Error Resume Next
        Set rngPersonnel = .Offset(1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        
        If Not rngPersonnel Is Nothing Then
            ' 批量复制到Personnel工作表
            lastRowPersonnel = wsPersonnel.Cells(wsPersonnel.Rows.Count, "A").End(xlUp).Row + 1
            rngPersonnel.Copy wsPersonnel.Cells(lastRowPersonnel, 1)
            ' 批量删除筛选出的行
            rngPersonnel.EntireRow.Delete
        End If
        
        ' 关闭筛选
        .AutoFilter
    End With
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    MsgBox "Abacus和Revolut数据已解码并合并到Combined工作表"
End Sub

关键优化点说明 #

1. 禁用Excel后台功能：脚本开头关闭屏幕更新、自动计算和事件触发，避免不必要的资源消耗，脚本结束后恢复
2. 使用数组批量读写：将工作表数据一次性读入数组，处理完成后再一次性写入，大幅减少单元格交互次数（这是提升速度最显著的优化）
3. 替换Collection为Dictionary：Scripting.Dictionary的键查找效率远高于Collection，且自带Exists方法，无需额外辅助函数
4. 批量复制/移动数据：
   • 合并数据时直接复制整个数据区域，而非逐行操作
   • 使用AutoFilter筛选出Personnel类别的行，批量复制删除，避免循环逐行处理
5. 简化逻辑：使用IIf函数简化映射查找的判断逻辑，减少代码冗余

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