Excel VBA跨表匹配复制数据运行崩溃 求代码优化方案

• 业务需求：在同一Excel工作簿内实现源工作表到目标工作表的定向数据复制：两张表均包含clarification number（澄清编号）列，无需复制该编号列，仅需将源表中指定澄清编号对应行的A-H列数据，写入目标表中相同澄清编号所在行的AI-AP列，保证跨表同编号的行数据一一关联，避免复制错位。
• 故障现象：当前编写的VBA代码可实现预期复制效果，但运行时Excel会持续3-4分钟显示“未响应”状态，随后要么崩溃关闭，要么留存空白Excel界面与VBA窗口；关闭文件后重新打开，会发现数据实际已经完成复制。文件体积较大，共设置3个按钮分别触发3个源工作表的复制逻辑，每个源表平均有3000-6000行数据，且现有行无法删减。
• 优化诉求：当前每次运行代码都需要关闭重开文件，实用性极差，初步判断性能问题出在嵌套For循环上，需要优化代码运行逻辑，解决卡顿崩溃问题。

Sub CopyColumnData()
    
    Dim wb As Workbook
    Dim myworksheet As Variant
    Dim workbookname As String
    
    
    ' DECLARE VARIABLES
    Dim i As Integer            ' Counter
    Dim j As Integer            ' Counter
    Dim colsSrc As Integer      ' PR Report: Source worksheet columns
    Dim colsDest As Integer     ' Open PR Data: Destination worksheet columns
    Dim rowsSrc As Long         ' Source worksheet rows
    Dim WsSrc As Worksheet      ' Source worksheet
    Dim WsDest As Worksheet     ' Destination worksheet
    
    Dim ws1PRRow As Long, ws1EndRow As Long, ws2PRRow As Long, ws2EndRow As Long
    Dim searchKey As String, foundKey As String
    
    workbookname = ActiveWorkbook.Name
    Set wb = ThisWorkbook
    myworksheet = "Sheet 1 copied Data"
    
    wb.Worksheets(myworksheet).Activate
    ' SET VARIABLES
    ' Source worksheet: Previous Report
    Set WsSrc = wb.Worksheets(myworksheet)
    
    Workbooks(workbookname).Sheets("Main Sheet").Activate
    ' Destination worksheet: Master Sheet
    Set WsDest = Workbooks(workbookname).Sheets("Main Sheet")
     
    'Adjust incase of change in column in both sheets
    ws1ORNum = "K"         'Clarification Number
    ws2ORNum = "K"         'Clarification Number
    ' Setting first and last row for the columns in both sheets
    ws1PRRow = 3              'The row we want to start processing first
    ws1EndRow = WsSrc.UsedRange.Rows(WsSrc.UsedRange.Rows.Count).Row
    ws2PRRow = 3              'The row we want to start search first
    ws2EndRow = WsDest.UsedRange.Rows(WsDest.UsedRange.Rows.Count).Row
    
    For i = ws1PRRow To ws1EndRow         ' first and last row
        searchKey = WsSrc.Range(ws1ORNum & i)
         'if we have a non blank search term then iterate through possible matches
        If (searchKey <> "") Then
            For j = ws2PRRow To ws2EndRow  ' first and last row
                 foundKey = WsDest.Range(ws2ORNum & j)
                  ' Copy result if there is a match between PR number and line in both sheets
                 If (searchKey = foundKey) Then
                    ' Copying data where the rows match
                        WsDest.Range("AI" & j).Value = WsSrc.Range("A" & i).Value
                        WsDest.Range("AJ" & j).Value = WsSrc.Range("B" & i).Value
                        WsDest.Range("AK" & j).Value = WsSrc.Range("C" & i).Value
                        WsDest.Range("AL" & j).Value = WsSrc.Range("D" & i).Value
                        WsDest.Range("AM" & j).Value = WsSrc.Range("E" & i).Value
                        WsDest.Range("AN" & j).Value = WsSrc.Range("F" & i).Value
                        WsDest.Range("AO" & j).Value = WsSrc.Range("G" & i).Value
                        WsDest.Range("AP" & j).Value = WsSrc.Range("H" & i).Value
                        
                        
                    Exit For
                 End If
            Next
        End If
    Next
  
    
    'Close Initial PR Report file
    wb.Save
    wb.Close
    
    'Pushbuttons are placed in Summary sheet
    'position to Instruction worksheet
    ActiveWorkbook.Worksheets("Summary").Select
    ActiveWindow.ScrollColumn = 1
    Range("A1").Select
    
    ActiveWorkbook.Worksheets("Summary").Select
    ActiveWindow.ScrollColumn = 1
    Range("A1").Select

End Sub

• 核心性能瓶颈为嵌套双层循环：若源表、目标表各有6000行数据，最坏情况需要执行3600万次单元格读取比对，且所有读写操作直接针对工作表单元格，频繁触发Excel界面重绘、事件响应，是程序假死崩溃的核心原因。
• 存在冗余错误逻辑：代码中重复激活工作表、重复选中Summary页，末尾直接执行wb.Close关闭整个工作簿，是运行后出现空白界面的直接原因。
• 变量声明不规范：循环计数器i/j声明为Integer类型，最大仅支持32767的数值，数据量上涨后容易出现溢出错误；ws1ORNum/ws2ORNum变量未提前声明，存在隐式类型转换风险。

Sub CopyColumnData()
    Dim wb As Workbook
    Dim WsSrc As Worksheet, WsDest As Worksheet
    Dim ws1EndRow As Long, ws2EndRow As Long
    Dim i As Long
    Dim searchKey As String
    Dim dict As Object
    Dim srcData As Variant, destData As Variant
    ' 存储原有Excel设置，运行结束后恢复
    Dim oldScreenUpdating As Boolean, oldEnableEvents As Boolean, oldCalc As XlCalculation
    
    On Error GoTo ErrorHandler ' 错误兜底，保证设置能恢复
    ' 关闭不必要的界面开销，大幅提升运行速度
    oldScreenUpdating = Application.ScreenUpdating
    oldEnableEvents = Application.EnableEvents
    oldCalc = Application.Calculation
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set wb = ThisWorkbook
    ' 按需修改源表名称即可适配3个按钮的逻辑
    Set WsSrc = wb.Worksheets("Sheet 1 copied Data")
    Set WsDest = wb.Worksheets("Main Sheet")
    Set dict = CreateObject("Scripting.Dictionary") ' 后期绑定字典，无需手动加引用
    
    ' 配置参数：两表澄清编号所在列、数据起始行
    Const srcClarCol As String = "K"
    Const destClarCol As String = "K"
    Const startRow As Long = 3
    
    ' 读取目标表所有澄清编号，存入字典建立「编号-行号」映射，仅需遍历一次
    ws2EndRow = WsDest.UsedRange.Rows(WsDest.UsedRange.Rows.Count).Row
    destData = WsDest.Range(destClarCol & startRow & ":" & destClarCol & ws2EndRow).Value
    For i = 1 To UBound(destData, 1)
        If Not IsError(destData(i, 1)) And Trim(destData(i, 1)) <> "" Then
            dict(CStr(destData(i, 1))) = i + startRow - 1 ' 存储对应实际行号
        End If
    Next i
    
    ' 读取源表所有需要的数据到内存数组，避免逐个读单元格
    ws1EndRow = WsSrc.UsedRange.Rows(WsSrc.UsedRange.Rows.Count).Row
    srcData = WsSrc.Range("A" & startRow & ":" & "K" & ws1EndRow).Value ' A到K列包含待复制的A-H列和K列编号
    
    ' 遍历源表数据，通过字典直接匹配目标行号，一次性写入数据
    For i = 1 To UBound(srcData, 1)
        If Not IsError(srcData(i, 11)) Then ' K列是第11列
            searchKey = Trim(CStr(srcData(i, 11)))
            If searchKey <> "" And dict.Exists(searchKey) Then
                ' 匹配到对应行，直接写入8列数据
                WsDest.Cells(dict(searchKey), "AI").Resize(1, 8).Value = Array( _
                    srcData(i, 1), srcData(i, 2), srcData(i, 3), srcData(i, 4), _
                    srcData(i, 5), srcData(i, 6), srcData(i, 7), srcData(i, 8))
            End If
        End If
    Next i
    
    wb.Save
    ' 跳转回Summary页，去掉冗余的重复选中逻辑
    wb.Worksheets("Summary").Select
    Range("A1").Select
    ActiveWindow.ScrollColumn = 1

ExitSub:
    ' 恢复Excel原有设置，避免功能异常
    Application.ScreenUpdating = oldScreenUpdating
    Application.EnableEvents = oldEnableEvents
    Application.Calculation = oldCalc
    Set dict = Nothing
    Exit Sub
ErrorHandler:
    MsgBox "运行出错：" & Err.Description, vbExclamation
    Resume ExitSub
End Sub

• 性能提升：用字典映射+内存数组的逻辑替换双层嵌套循环，时间复杂度从O(n*m)降到O(n+m)，6000行级别的数据运行时间通常在1秒以内，不会出现长时间未响应。
• 稳定性优化：增加错误兜底机制，无论代码正常运行还是中途报错，都会自动恢复Excel的屏幕更新、事件响应、自动计算设置，不会出现界面卡死、功能残留异常的问题。
• 适配性强：仅需修改代码中源表名称参数，即可复用到另外2个源表的复制按钮逻辑，无需重复编写多套代码。
• 逻辑一致：匹配规则和原代码完全一致，仅匹配第一个对应澄清编号的行写入数据，不会改变原有业务逻辑。

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