请求优化批量生成多级BOM的卡顿VBA代码

原代码处理大量BOM数据时卡顿严重，核心问题有两个：一是每次递归都要遍历Sheet1的所有行，重复查询效率极低；二是逐单元格写入数据，频繁和Excel交互拖慢速度。以下是优化后的代码，解决了这些问题：

优化核心点 #

• 用字典预存所有BOM父子件关系，查询子件直接从字典取，无需重复遍历整表
• 用数组暂存输出数据，最后一次性写入工作表，大幅减少单元格操作
• 关闭Excel屏幕更新、自动计算等，避免不必要的资源消耗
• 补充了原代码缺失的Total Qty计算逻辑

优化后完整代码 #

Sub GenerateMultiLevelBOM()
    Dim wsBOM As Worksheet, wsFG As Worksheet, wsOutput As Worksheet
    Dim bomDict As Object, outputArr As Variant
    Dim lastRowBOM As Long, lastRowFG As Long, outputRow As Long, i As Long
    Dim fgCode As String, fgDesc As String
    
    ' 关闭Excel耗时功能
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' 初始化工作表
    Set wsBOM = ThisWorkbook.Sheets("Sheet1")
    Set wsFG = ThisWorkbook.Sheets("Sheet2")
    On Error Resume Next
    Set wsOutput = ThisWorkbook.Sheets("BOM_Output")
    If Err.Number <> 0 Then
        Set wsOutput = ThisWorkbook.Sheets.Add
        wsOutput.Name = "BOM_Output"
    End If
    On Error GoTo 0
    wsOutput.Cells.Clear
    
    ' 预存BOM数据到字典：Key=父件编码，Item=子件数组（编码、描述、数量）
    Set bomDict = CreateObject("Scripting.Dictionary")
    lastRowBOM = wsBOM.Cells(wsBOM.Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To lastRowBOM
        Dim parentCode As String, childCode As String, childDesc As String, qty As Double
        parentCode = CStr(wsBOM.Cells(i, 1).Value)
        childCode = CStr(wsBOM.Cells(i, 3).Value)
        childDesc = wsBOM.Cells(i, 4).Value
        qty = wsBOM.Cells(i, 6).Value
        
        If Not bomDict.Exists(parentCode) Then
            bomDict(parentCode) = New Collection
        End If
        bomDict(parentCode).Add Array(childCode, childDesc, qty)
    Next i
    
    ' 初始化输出数组（预分配足够空间，避免频繁扩容）
    ReDim outputArr(1 To 100000, 1 To 8)
    outputRow = 1
    
    ' 写入表头
    outputArr(outputRow, 1) = "FG Code"
    outputArr(outputRow, 2) = "Level"
    outputArr(outputRow, 3) = "Parent Code"
    outputArr(outputRow, 4) = "Parent Description"
    outputArr(outputRow, 5) = "Child Code"
    outputArr(outputRow, 6) = "Child Description"
    outputArr(outputRow, 7) = "Qty"
    outputArr(outputRow, 8) = "Total Qty"
    outputRow = outputRow + 1
    
    ' 遍历成品清单，生成多级BOM
    lastRowFG = wsFG.Cells(wsFG.Rows.Count, "A").End(xlUp).Row
    For i = 2 To lastRowFG
        fgCode = CStr(wsFG.Cells(i, 1).Value)
        fgDesc = wsFG.Cells(i, 2).Value
        ' 递归生成BOM，传入顶层数量1
        RecurseBOM bomDict, fgCode, fgDesc, fgCode, 0, 1#, outputArr, outputRow
    Next i
    
    ' 把数组写入输出工作表
    wsOutput.Range("A1:H" & outputRow - 1).Value = outputArr
    ' 设置文本格式避免编码变成数字
    wsOutput.Range("A:A,C:C,E:E").NumberFormat = "@"
    wsOutput.Columns("A:H").AutoFit
    
    ' 恢复Excel功能
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    MsgBox "多级BOM生成完成！", vbInformation
End Sub

Sub RecurseBOM(bomDict As Object, parentCode As String, parentDesc As String, fgCode As String, _
               level As Integer, totalQty As Double, ByRef outputArr As Variant, ByRef outputRow As Long)
    If Not bomDict.Exists(parentCode) Then Exit Sub
    
    Dim childItem As Variant
    For Each childItem In bomDict(parentCode)
        Dim childCode As String, childDesc As String, qty As Double
        childCode = childItem(0)
        childDesc = childItem(1)
        qty = childItem(2)
        Dim currentTotalQty As Double
        currentTotalQty = totalQty * qty
        
        ' 写入当前行到数组
        outputArr(outputRow, 1) = fgCode
        outputArr(outputRow, 2) = level
        outputArr(outputRow, 3) = parentCode
        outputArr(outputRow, 4) = parentDesc
        outputArr(outputRow, 5) = childCode
        outputArr(outputRow, 6) = childDesc
        outputArr(outputRow, 7) = qty
        outputArr(outputRow, 8) = currentTotalQty
        outputRow = outputRow + 1
        
        ' 递归处理子件
        RecurseBOM bomDict, childCode, childDesc, fgCode, level + 1, currentTotalQty, outputArr, outputRow
    Next childItem
End Sub

代码说明 #

1. 字典预存BOM：把Sheet1的所有父子件关系存入字典，后续查询子件直接从字典获取，时间复杂度从O(n)降到O(1)
2. 数组批量写入：所有输出数据先存在数组里，最后一次性写入工作表，避免了成千上万次的单元格写入操作
3. 性能开关：关闭屏幕更新、自动计算等，减少Excel后台操作
4. Total Qty计算：递归时传递累计数量，自动计算每个子件相对于顶层成品的总数量

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