VBA嵌套for循环跨表匹配复制数据 如何优化提速

你当前代码运行极慢的核心原因有两个：一是逐单元格读取值做双层循环比对，二是调用剪贴板做逐行Copy/Paste操作，都是VBA里效率最低的写法。针对你的场景（仅16行待匹配值，1.5万行被查找数据），按提速效果排序，可落地的方案如下：

1. 最高效方案：字典匹配+数组批量读写（提速1000倍以上，全量1.5万行运行时长<1秒） #

核心逻辑：

• 把仅16行的待匹配表（Anagrafica）的A列值、对应B:D列待复制内容，一次性存入字典，查找时间复杂度从O(n*m)降到O(1)
• 把1.5万行的目标表（Calcoli）的A列、待写入的W:Y区域一次性读入内存数组，全程不碰工作表单元格
• 遍历一次数组完成匹配赋值，最后一次性把数组写回工作表，完全避开逐单元格操作和剪贴板开销

参考可直接运行的代码：

Dim ws As Worksheet, ws2 As Worksheet
Dim Last_calcoli As Long, Last_anagrafica As Long, T0 As Single
Dim arrSource As Variant, arrTarget As Variant, arrMatchCol As Variant
Dim dict As Object, i As Long

Set ws = Worksheets("Calcoli")
Set ws2 = Worksheets("Anagrafica")
T0 = Timer

' 保存原Excel设置
ScreenUpdateState = Application.ScreenUpdating
StatusBarState = Application.DisplayStatusBar
CalcState = Application.Calculation
EventsState = Application.EnableEvents
DisplayPageBreakState = ActiveSheet.DisplayPageBreaks
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

' 取两个表的有效行号
Last_calcoli = ws.Cells(Rows.Count, 1).End(xlUp).Row
Last_anagrafica = ws2.Cells(Rows.Count, 1).End(xlUp).Row

' 初始化字典，存储待匹配的键和对应要复制的内容
Set dict = CreateObject("Scripting.Dictionary")
arrSource = ws2.Range("A2:D" & Last_anagrafica).Value ' 一次性读入所有待匹配数据
For i = 1 To UBound(arrSource, 1)
    If Not dict.exists(arrSource(i, 1)) Then
        dict(arrSource(i, 1)) = Array(arrSource(i, 2), arrSource(i, 3), arrSource(i, 4))
    End If
Next i

' 读目标表的匹配列、待写入列到内存数组
arrMatchCol = ws.Range("A2:A" & Last_calcoli).Value
arrTarget = ws.Range("W2:Y" & Last_calcoli).Value

' 内存中完成匹配赋值
For i = 1 To UBound(arrMatchCol, 1)
    If dict.exists(arrMatchCol(i, 1)) Then
        arrTarget(i, 1) = dict(arrMatchCol(i, 1))(0)
        arrTarget(i, 2) = dict(arrMatchCol(i, 1))(1)
        arrTarget(i, 3) = dict(arrMatchCol(i, 1))(2)
    End If
Next i

' 一次性把结果写回工作表
ws.Range("W2:Y" & Last_calcoli).Value = arrTarget

' 恢复原有Excel设置
Application.ScreenUpdating = ScreenUpdateState
Application.DisplayStatusBar = StatusBarState
Application.Calculation = CalcState
Application.EnableEvents = EventsState
ActiveSheet.DisplayPageBreaks = DisplayPageBreakState

InputBox "The runtime of this program is", "Runtime", Timer - T0

2. 轻量改法：用Range.Find代替内层循环+直接值赋值（提速100倍以上，全量运行时长<5秒） #

如果不想学习数组和字典写法，只修改原有循环逻辑也能大幅提速：

• 去掉内层遍历1.5万行的VBA层循环，改用Excel原生的Find方法查找匹配值，原生方法由C++实现，比VBA写的循环快得多
• 把Copy+PasteSpecial的剪贴板操作改成直接跨区域赋值，避开剪贴板开销

核心修改后的循环段代码：

Dim findRng As Range
For a = 2 To Last_anagrafica
    MyString2 = ws2.Cells(a, 1).Value ' 直接用提前定义的ws2对象，不要重复取工作表
    ' 在Calcoli的A列精确查找匹配值
    Set findRng = ws.Range("A2:A" & Last_calcoli).Find(What:=MyString2, LookIn:=xlValues, LookAt:=xlWhole)
    If Not findRng Is Nothing Then
        ' 直接赋值，无需调用剪贴板
        ws.Range("W" & findRng.Row & ":Y" & findRng.Row).Value = ws2.Range("B" & a & ":D" & a).Value
    End If
Next a

3. 原有代码的额外优化细节 #

• 不要在循环里反复写Worksheets("Anagrafica")、Worksheets("Calcoli")，提前定义好工作表对象后直接调用即可，每次从工作簿集合取工作表都会产生额外开销
• 所有单元格读值时显式加.Value，避免触发单元格默认属性的判断开销
• 非必要不要用Copy+PasteSpecial做值复制，直接用等号赋值的效率是剪贴板操作的几十上百倍，还不会受其他软件占用剪贴板的影响

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