Excel 2019 VBA宏长时间冻结崩溃问题求助

我是VBA编程新手，编写了一个用于比对两个数据集的宏，通过双层循环查找两表特定列的匹配项，并将匹配行的指定信息转至新工作表。但数据量较大时，宏运行会冻结30分钟后崩溃，已尝试禁用屏幕刷新但未解决问题，现寻求可行解决方案。

原代码： #

Sub TransposeMatchedDataWithArray()
    'Declare variables for the worksheets
    Dim wsFormula As Worksheet, wsFormula2 As Worksheet, wsFormula3 As Worksheet
    'Set the variables to the corresponding worksheets
    Set wsFormula = ThisWorkbook.Sheets("Formula")
    Set wsFormula2 = ThisWorkbook.Sheets("Formula2")
    Set wsFormula3 = ThisWorkbook.Sheets("Formula3")
    'Declare variables for the named ranges
    Dim rngStart As Range, rngEnd As Range
    'Set the variables to the corresponding named ranges
    Set rngStart = wsFormula.Range("Start_Date_Table")
    Set rngEnd = wsFormula2.Range("End_Date_Table")
    'Clear the data in Formula3
    wsFormula3.Cells.Clear
    'Add the headings in Formula3
    wsFormula3.Range("A1").Value = "Start_Date"
    wsFormula3.Range("B1").Value = "AGLC SKU"
    wsFormula3.Range("C1").Value = "Format"
    wsFormula3.Range("D1").Value = "Subcategory"
    wsFormula3.Range("E1").Value = "Company Name"
    wsFormula3.Range("F1").Value = "Brand Name"
    wsFormula3.Range("G1").Value = "SKU DESCRIPTION"
    wsFormula3.Range("H1").Value = "Available Cases"
    wsFormula3.Range("I1").Value = "Case Cost (w/s)"
    wsFormula3.Range("J1").Value = "Case Value $"
    wsFormula3.Range("K1").Value = "End_Date"
    wsFormula3.Range("L1").Value = "Available Cases"
    wsFormula3.Range("M1").Value = "Case Cost (w/s)"
    wsFormula3.Range("N1").Value = "Case Value $"
    'Declare an array to hold the data from the Start_Date_Table
    Dim startArray As Variant
    'Fill the array with the data from the Start_Date_Table
    startArray = rngStart.Value
    'Declare an array to hold the data from the End_Date_Table
    Dim endArray As Variant
    'Fill the array with the data from the End_Date_Table
    endArray = rngEnd.Value
    'Declare a variable for the current row in Formula3
    Dim currentRow As Long
    currentRow = 2
    'Iterate through the rows in the startArray
    For i = 2 To UBound(startArray, 1)
        'Iterate through the rows in the endArray
        For j = 2 To UBound(endArray, 1)
            'Check if the AGLC SKU in the current rows of the startArray and endArray match
            If startArray(i, 2) = endArray(j, 2) Then
'Write the data from the startArray to the current row of Formula3
                wsFormula3.Range("A" & currentRow).Value = startArray(i, 1)
                wsFormula3.Range("B" & currentRow).Value = startArray(i, 2)
                wsFormula3.Range("C" & currentRow).Value = startArray(i, 3)
                wsFormula3.Range("D" & currentRow).Value = startArray(i, 4)
                wsFormula3.Range("E" & currentRow).Value = startArray(i, 5)
                wsFormula3.Range("F" & currentRow).Value = startArray(i, 6)
                wsFormula3.Range("G" & currentRow).Value = startArray(i, 7)
                wsFormula3.Range("H" & currentRow).Value = startArray(i, 8)
                wsFormula3.Range("I" & currentRow).Value = startArray(i, 9)
                wsFormula3.Range("J" & currentRow).Value = startArray(i, 10)
                wsFormula3.Range("K" & currentRow).Value = endArray(j, 1)
                wsFormula3.Range("L" & currentRow).Value = endArray(j, 8)
                wsFormula3.Range("M" & currentRow).Value = endArray(j, 9)
                wsFormula3.Range("N" & currentRow).Value = endArray(j, 10)
                'Increment the currentRow variable
                currentRow = currentRow + 1
            End If
        Next j
    Next i
End Sub

优化方案及代码 #

核心优化点：

• 用**字典（Dictionary）**替代双层循环，将查找时间复杂度从O(n*m)降到O(n+m)，彻底解决大数据量下的性能瓶颈
• 所有结果先存入数组，最后一次性写入工作表，避免频繁的单元格IO操作
• 添加完整的性能优化开关（禁用屏幕刷新、事件触发、自动计算）

优化后的代码：

Sub FastMatchData()
    Dim wsFormula As Worksheet, wsFormula2 As Worksheet, wsFormula3 As Worksheet
    Dim rngStart As Range, rngEnd As Range
    Dim startArray As Variant, endArray As Variant
    Dim resultArray As Variant
    Dim skuDict As Object
    Dim i As Long, currentRow As Long, j As Long
    Dim lastResultRow As Long
    
    '===== 性能优化开关 =====
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    '初始化工作表
    Set wsFormula = ThisWorkbook.Sheets("Formula")
    Set wsFormula2 = ThisWorkbook.Sheets("Formula2")
    Set wsFormula3 = ThisWorkbook.Sheets("Formula3")
    Set rngStart = wsFormula.Range("Start_Date_Table")
    Set rngEnd = wsFormula2.Range("End_Date_Table")
    
    '清空目标表并写入表头
    wsFormula3.Cells.Clear
    With wsFormula3.Range("A1:N1")
        .Value = Array("Start_Date", "AGLC SKU", "Format", "Subcategory", _
                      "Company Name", "Brand Name", "SKU DESCRIPTION", _
                      "Available Cases", "Case Cost (w/s)", "Case Value $", _
                      "End_Date", "Available Cases", "Case Cost (w/s)", "Case Value $")
        .Font.Bold = True
    End With
    
    '读取数据到数组
    startArray = rngStart.Value
    endArray = rngEnd.Value
    
    '创建字典存储End表的SKU对应数据
    Set skuDict = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(endArray, 1)
        '用SKU作为键，存储需要的列数据（1,8,9,10列）
        If Not skuDict.Exists(endArray(i, 2)) Then
            skuDict(endArray(i, 2)) = Array(endArray(i, 1), endArray(i, 8), endArray(i, 9), endArray(i, 10))
        End If
    Next i
    
    '初始化结果数组（假设最大行数和Start表一致，可按需调整）
    ReDim resultArray(1 To UBound(startArray, 1) - 1, 1 To 14)
    currentRow = 1
    
    '遍历Start表，匹配SKU并填充结果数组
    For i = 2 To UBound(startArray, 1)
        If skuDict.Exists(startArray(i, 2)) Then
            '填充Start表的1-10列数据
            For j = 1 To 10
                resultArray(currentRow, j) = startArray(i, j)
            Next j
            '填充End表匹配到的数据
            Dim endData As Variant
            endData = skuDict(startArray(i, 2))
            resultArray(currentRow, 11) = endData(0)
            resultArray(currentRow, 12) = endData(1)
            resultArray(currentRow, 13) = endData(2)
            resultArray(currentRow, 14) = endData(3)
            currentRow = currentRow + 1
        End If
    Next i
    
    '将结果数组写入目标表
    If currentRow > 1 Then
        lastResultRow = currentRow - 1
        wsFormula3.Range("A2:N" & lastResultRow + 1).Value = resultArray
    End If
    
    '===== 恢复Excel设置 =====
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "匹配完成，共找到" & currentRow - 1 & "条匹配数据", vbInformation
End Sub

额外说明： #

• 如果存在同一个SKU对应多条End表数据的情况，可修改字典存储方式，将对应数据存入集合，遍历集合完成多匹配写入
• 确保Start_Date_Table和End_Date_Table两个命名范围包含所有需要的数据行，且列顺序和代码中一致

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