基于Town&Month匹配的Excel跨表数据复制高效实现方案问询

我在Excel的工作表A中有一张包含基础数据的Table1：

另一张工作表中有Table2，仅包含多行Town和Month数据。我需要在两表的Town和Month值同时匹配时，将Table1的Sth列数据复制到Table2对应行。

目前我用双重循环实现：外层遍历Table2的每一行，内层遍历Table1的每一行对比Town&Month，匹配成功就复制对应区域。想知道有没有更高效的实现方式，比如用数组对比等。

以下是我的VBA代码：

Sub kopiuj()
    Dim row As Long
    Dim copyRng As Range, pasteRng As Range
    
    row = 7
    If IsEmpty(Cells(row, 3)) Then
        MsgBox "No data"
        Exit Sub
    End If
    Do Until IsEmpty(Cells(row, 3))
     If IsEmpty(Cells(row, 7)) And Cells(row, 6) = "xxx" Then
          MsgBox "No data"
           Exit Sub
     End If
     Set copyRng = szukaj2(Cells(row, 6).Value, Cells(row, 7).Value)
     If Not copyRng Is Nothing Then
        Set pasteRng = Range(Cells(row, 8), Cells(row, 25))
        copyRng.Copy pasteRng
     End If
     row = row + 1
    Loop
End Sub

Function szukaj2(ByVal przedplon As String, ByVal plon As String) As Range
  Dim PN As Worksheet
  Dim row As Integer
  Set PN = ActiveWorkbook.Sheets("XXX")
  Dim rg As Range
    
  For row = 7 To PN.Cells(Rows.Count, 4).End(xlUp).row Step 1

    If StrComp(przedplon, PN.Cells(row, 3).Value, vbTextCompare) = 0 And StrComp(plon, PN.Cells(row, 1).Value, vbTextCompare) = 0 Then
     With PN
     Set rg = .Range(.Cells(row, 8), .Cells(row, 25))
     End With
     Set szukaj2 = rg
     Exit For
    End If
  Next
End Function

双重循环的时间复杂度为O(n*m)，数据量较大时效率会急剧下降。最实用的优化方式是用**字典（Dictionary）**构建Table1的索引，将Town|Month作为唯一键，对应存储需要复制的Sth列数据数组，匹配时仅需O(1)查找时间，整体时间复杂度降至O(n+m)。

优化后的VBA代码 #

Sub CopyMatchingData()
    Dim wsTable1 As Worksheet, wsTable2 As Worksheet
    Dim dict As Object
    Dim table1Data As Variant, table2Data As Variant
    Dim i As Long, j As Long
    Dim key As String
    Dim lastRowTable1 As Long, lastRowTable2 As Long
    Dim copyColsCount As Integer
    
    ' 定义工作表（根据实际情况修改）
    Set wsTable1 = ThisWorkbook.Sheets("XXX") ' 对应原代码中Table1所在的"XXX"工作表
    Set wsTable2 = ThisWorkbook.ActiveSheet ' 对应原代码中Table2所在的活动工作表
    Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' 匹配时不区分大小写
    
    ' 将Table1数据一次性读入数组（减少单元格交互，提升性能）
    lastRowTable1 = wsTable1.Cells(wsTable1.Rows.Count, 1).End(xlUp).Row
    table1Data = wsTable1.Range("A7:Y" & lastRowTable1).Value ' 覆盖第1到25列，对应原代码的复制范围
    
    ' 构建字典：键为Town+Month，值为第8-25列的Sth数据数组
    copyColsCount = 25 - 8 + 1 ' 共18列需要复制
    For i = 1 To UBound(table1Data)
        ' 原代码中przedplon对应Table1第3列（Town），plon对应第1列（Month）
        key = table1Data(i, 3) & "|" & table1Data(i, 1) ' 用|分隔避免Town和Month拼接冲突
        ' 存储需要复制的列数据
        Dim tempArr As Variant
        ReDim tempArr(1 To copyColsCount)
        For j = 1 To copyColsCount
            tempArr(j) = table1Data(i, 7 + j) ' 第8列对应数组索引8，7+1=8
        Next j
        dict(key) = tempArr
    Next i
    
    ' 将Table2数据一次性读入数组
    lastRowTable2 = wsTable2.Cells(wsTable2.Rows.Count, 3).End(xlUp).Row
    table2Data = wsTable2.Range("C7:Y" & lastRowTable2).Value ' 覆盖第3到25列，对应原代码的操作范围
    
    ' 遍历Table2数组，匹配字典并写入数据
    For i = 1 To UBound(table2Data)
        ' 原代码中Table2的Town在第6列（F列）、Month在第7列（G列），对应数组第4、5位（从C列开始计数）
        key = table2Data(i, 4) & "|" & table2Data(i, 5)
        If dict.Exists(key) Then
            ' 将匹配到的数据写入Table2第8-25列（对应数组第6-23位）
            For j = 1 To copyColsCount
                table2Data(i, 5 + j) = dict(key)(j)
            Next j
        End If
    Next i
    
    ' 一次性将处理后的数组写回工作表，大幅减少IO操作
    wsTable2.Range("C7:Y" & lastRowTable2).Value = table2Data
    
    MsgBox "数据复制完成！"
End Sub

核心优化点 #

1. 减少单元格交互：将表格数据一次性读入数组，避免循环中反复读写单元格（VBA性能瓶颈的主要来源）。
2. 字典索引匹配：提前构建Table1的索引，匹配时直接查找，彻底消除内层循环。
3. 批量写入数据：处理完数组后一次性写回工作表，避免多次IO操作。

额外性能提升建议 #

如果数据量极大，可在代码开头添加：

Application.ScreenUpdating = False
Application.EnableEvents = False

代码执行完毕后恢复：

Application.ScreenUpdating = True
Application.EnableEvents = True

内容的提问来源于stack exchange，提问作者Filip Frątczak