求助：如何优化VBA跨工作表数据复制代码以提升性能？

首先得说，你的原代码慢的核心原因有两个：频繁的单元格读写操作（每次Cells访问都要和Excel界面交互，速度极慢），还有嵌套循环的时间复杂度太高（O(n*m)，当数据量大时会指数级变慢）。下面给你一套立竿见影的优化方案：

核心优化思路 #

• 把所有数据一次性读到内存数组里，在内存中完成匹配计算，最后再一次性写回工作表
• 用Dictionary（字典）来存储匹配键值对，把嵌套循环的高复杂度降到线性级别
• 关闭Excel的后台干扰项（屏幕更新、自动计算、事件触发）

优化后的完整代码 #

Sub BRM_ID1_Optimized()
    Dim SourceData As Worksheet, TailoredData As Worksheet
    Dim sourceArr As Variant, targetArr As Variant
    Dim matchDict As Object
    Dim i As Long, j As Long
    
    ' 初始化工作表对象
    Set SourceData = ActiveWorkbook.Worksheets("SZCategoryData")
    Set TailoredData = ActiveWorkbook.Worksheets("SZCategory tailored")
    Set matchDict = CreateObject("Scripting.Dictionary")
    
    ' 关闭Excel性能阻碍项
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    On Error GoTo Cleanup ' 确保出错时能恢复设置
    
    ' 把源数据读到数组（只取需要的列：A、E、F）
    sourceArr = SourceData.Range("A2:F" & SourceData.Cells(SourceData.Rows.Count, "A").End(xlUp).Row).Value
    
    ' 用字典存储匹配关系：Key是A列值，Value是对应BRM_ID的E列值
    For i = LBound(sourceArr, 1) To UBound(sourceArr, 1)
        If sourceArr(i, 6) = "BRM_ID" Then ' F列是BRM_ID的行
            ' 避免重复键，如果有重复可以根据需求覆盖或跳过
            If Not matchDict.Exists(sourceArr(i, 1)) Then
                matchDict(sourceArr(i, 1)) = sourceArr(i, 5)
            End If
        End If
        ' 如果还有RELEASE的匹配逻辑，这里可以同样处理，比如再建一个字典或者存数组
    Next i
    
    ' 把目标数据读到数组
    targetArr = TailoredData.Range("A2:B" & TailoredData.Cells(TailoredData.Rows.Count, "A").End(xlUp).Row).Value
    
    ' 在数组中完成匹配赋值
    For j = LBound(targetArr, 1) To UBound(targetArr, 1)
        If matchDict.Exists(targetArr(j, 1)) Then
            targetArr(j, 2) = matchDict(targetArr(j, 1))
        End If
        ' RELEASE的匹配逻辑同理，这里可以补充
    Next j
    
    ' 把数组写回目标工作表
    TailoredData.Range("A2").Resize(UBound(targetArr, 1), UBound(targetArr, 2)).Value = targetArr
    
Cleanup:
    ' 恢复Excel默认设置
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
    
    ' 释放对象
    Set matchDict = Nothing
    Set SourceData = Nothing
    Set TailoredData = Nothing
    
    If Err.Number <> 0 Then
        MsgBox "执行出错: " & Err.Description, vbCritical
    End If
End Sub

关键优化点解释 #

• 数组读写：一次性把整段数据读到数组，比逐个单元格访问快100倍以上，因为内存操作远快于和Excel界面交互
• 字典匹配：用字典的Exists方法查找键，时间复杂度是O(1)，替代原来的嵌套循环（O(n*m)），数据量越大，提升越明显
• 关闭后台设置：屏幕更新会每次刷新界面，自动计算会在单元格变化时重新计算，这些都极大拖慢速度，执行完必须恢复
• 动态获取数据范围：原代码用固定的1000行，改成End(xlUp)自动获取最后一行，避免处理空行，也适配数据量变化

如果你的代码里还有RELEASE的匹配逻辑，只需要在字典部分再处理一次（比如新建一个字典存储RELEASE的对应值），然后在目标数组赋值时补充判断即可。

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