Excel宏运行错误'-2147417848'：大数据量分发失败求优化方案

问题根源 #

你当前的代码采用逐行遍历单元格+逐行复制整行的逻辑，这种操作在大数据量下会产生巨量的工作表交互开销——Excel需要反复刷新界面、计算关联公式，最终导致无响应甚至报错。不同工作簿的格式复杂度、公式数量、加载项差异，会触发不同的表现，这就是为什么一个工作簿正常、另一个出错的原因。

优化方案：两种高效实现方式 #

方式1：数组批量处理（效率最高） #

把源数据一次性读到内存数组中，遍历数组完成分类后再批量写入目标工作表，全程以内存交互为主，大幅降低工作表读写次数：

Sub Disperse_Data_Array()
    Dim wsSource As Worksheet
    Dim arrSource As Variant
    Dim rowCount As Long, colCount As Long
    Dim i As Long, j As Long
    Dim dict As Object
    Dim key As Variant
    Dim wsTarget As Worksheet
    Dim targetRow As Long
    Dim rowArr() As Variant
    
    ' 关闭Excel交互，大幅提升速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 绑定源工作表与数据数组
    Set wsSource = Selection.Parent
    arrSource = Selection.Value
    rowCount = UBound(arrSource, 1)
    colCount = UBound(arrSource, 2)
    
    ' 用字典存储分类对应的行数据
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 遍历数组完成数据分类
    For i = 1 To rowCount
        key = arrSource(i, 4) ' 以第四列值作为分类键
        If Not dict.Exists(key) Then
            dict(key) = New Collection
        End If
        ' 提取当前行数据存入集合
        ReDim rowArr(1 To colCount)
        For j = 1 To colCount
            rowArr(j) = arrSource(i, j)
        Next j
        dict(key).Add rowArr
    Next i
    
    ' 批量写入分类后的数据到目标工作表
    For Each key In dict
        ' 检查目标工作表是否存在
        On Error Resume Next
        Set wsTarget = ThisWorkbook.Worksheets("SU" & key)
        On Error GoTo 0
        If Not wsTarget Is Nothing Then
            targetRow = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
            For Each item In dict(key)
                wsTarget.Cells(targetRow, 1).Resize(1, colCount).Value = item
                targetRow = targetRow + 1
            Next item
        End If
        Set wsTarget = Nothing
    Next key
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

方式2：AutoFilter批量复制（代码更简洁） #

利用Excel原生筛选功能，一次性筛选出目标分类数据，再批量复制到对应工作表，效率远高于逐行循环：

Sub Disperse_Data_Filter()
    Dim wsSource As Worksheet
    Dim rngSource As Range
    Dim targetWs As Worksheet
    Dim filterValue As Variant
    Dim filterList As Variant
    
    ' 关闭Excel交互
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    Set wsSource = Selection.Parent
    ' 绑定完整的源数据区域
    Set rngSource = wsSource.Range("A1:" & wsSource.Cells(Selection.Row + Selection.Rows.Count - 1, Selection.Column + Selection.Columns.Count - 1).Address)
    
    ' 替换为你的实际分类值列表
    filterList = Array("400", "500", "600")
    
    For Each filterValue In filterList
        ' 检查目标工作表是否存在
        On Error Resume Next
        Set targetWs = ThisWorkbook.Worksheets("SU" & filterValue)
        On Error GoTo 0
        If Not targetWs Is Nothing Then
            ' 清除原有筛选
            wsSource.AutoFilterMode = False
            ' 筛选第四列的目标值
            rngSource.AutoFilter Field:=4, Criteria1:=filterValue
            ' 批量复制可见行到目标工作表
            rngSource.SpecialCells(xlCellTypeVisible).Copy targetWs.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Next filterValue
    
    ' 清除筛选状态
    wsSource.AutoFilterMode = False
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
End Sub

额外注意事项 #

• 确保目标工作表（如SU400）已存在，若需自动创建工作表，可在代码中添加判断创建逻辑。
• 若源数据包含表头，需调整遍历或筛选的起始行，避免重复复制表头。
• 测试前请备份数据，避免意外数据覆盖。

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