Excel VBA批量复制数据崩溃，求数组处理转新表方案

环境设置 #

• Excel文件源数据位于A至J列
• K列为「发送类型」，值为"Many"或"Single"
• L列为「发送次数（N）」，为数值类型

需求目标 #

• 复制源数据，根据L列的N值重复对应行：
  • 若N=1，保持该行不变
  • 若N>1，将该行数据重复显示N次（需插入N-1行并粘贴数据）

当前VBA代码 #

Sub Copy_PROD_Paste_Send_Count()

    Dim Copy_Row        As Integer
    Dim Send_Count      As Variant
    Dim TargetMapCount  As Integer
    Dim ProgressCount   As Integer
    Dim Send_Type       As String
    Dim ProgressTarget  As Integer
   
    Copy_Row = 1
    TargetMapCount = Application.WorksheetFunction.SumIf(Range("K:K"), "Many", Range("L:L"))
    Send_Type = Cells(Copy_Row, "K")
    ProgressTarget = Application.WorksheetFunction.Count(Range("A:A")) + Application.WorksheetFunction.SumIf(Range("K:K"), "Many", Range("L:L")) - Application.WorksheetFunction.CountIf(Range("K:K"), "Many")
    
    Application.ScreenUpdating = False
        
    Do While (Cells(Copy_Row, "A") <> "")
        Send_Count = Cells(Copy_Row, "L")
        Send_Type = Cells(Copy_Row, "K")

        If (Send_Type = "Many" And (Send_Count > 1) And IsNumeric(Send_Count)) Then
            
            Range(Cells(Copy_Row, "A"), Cells(Copy_Row, "L")).Copy
            Range(Cells(Copy_Row + 1, "A"), Cells(Copy_Row + Send_Count - 1, "L")).Select
            Selection.Insert Shift:=xlDown
            Copy_Row = Copy_Row + Send_Count - 1
                    
            ProgressCount = Range("A" & Rows.Count).End(xlUp).Row
                         
            Application.StatusBar = "Updating :" & ProgressCount - 1 & " of " & ProgressTarget & ": " & Format((ProgressCount - 1) / ProgressTarget, "0%")
                
        End If
        Copy_Row = Copy_Row + 1
          
    Loop        

End Sub

问题描述 #

当前宏处理2-3千行数据时崩溃，需要支持1.5万行数据的处理。已知改用数组读取+内存处理+一次性写入的方式能解决问题，但不清楚具体实现。

优化后的VBA代码（数组版） #

Sub RepeatRowsWithArray()
    Dim srcWS As Worksheet, destWS As Worksheet
    Dim srcArr As Variant, destArr As Variant
    Dim lastRow As Long, totalRows As Long
    Dim i As Long, j As Long, k As Long, repeatCount As Long
    
    ' 定义源工作表和目标工作表（用新工作表避免覆盖原数据）
    Set srcWS = ThisWorkbook.ActiveSheet
    Set destWS = ThisWorkbook.Sheets.Add(After:=srcWS)
    destWS.Name = "重复后数据"
    
    ' 读取源数据到数组（A到L列）
    lastRow = srcWS.Cells(srcWS.Rows.Count, "A").End(xlUp).Row
    srcArr = srcWS.Range("A1:L" & lastRow).Value
    
    ' 计算目标数组的总行数
    totalRows = 0
    For i = 1 To UBound(srcArr)
        repeatCount = srcArr(i, 12) ' L列是第12列
        ' 只有Send_Type为Many且重复次数>1时，按N次计算；否则按1次
        If srcArr(i, 11) = "Many" And IsNumeric(repeatCount) And repeatCount > 1 Then
            totalRows = totalRows + repeatCount
        Else
            totalRows = totalRows + 1
        End If
    Next i
    
    ' 初始化目标数组
    ReDim destArr(1 To totalRows, 1 To 12) ' 12列对应A-L
    
    ' 填充目标数组
    k = 1 ' 目标数组行指针
    For i = 1 To UBound(srcArr)
        repeatCount = srcArr(i, 12)
        ' 确定当前行需要重复的次数
        If srcArr(i, 11) = "Many" And IsNumeric(repeatCount) And repeatCount > 1 Then
            ' 重复N次
            For j = 1 To repeatCount
                ' 复制当前行的所有列数据
                For col = 1 To 12
                    destArr(k, col) = srcArr(i, col)
                Next col
                k = k + 1
            Next j
        Else
            ' 只复制1次
            For col = 1 To 12
                destArr(k, col) = srcArr(i, col)
            Next col
            k = k + 1
        End If
        
        ' 更新状态栏进度
        Application.StatusBar = "处理进度: " & k - 1 & " / " & totalRows & " (" & Format((k - 1) / totalRows, "0%") & ")"
    Next i
    
    ' 将目标数组写入工作表
    destWS.Range("A1:L" & totalRows).Value = destArr
    
    ' 清理状态栏，恢复屏幕更新
    Application.StatusBar = False
    Application.ScreenUpdating = True
    
    MsgBox "处理完成！结果已写入工作表「" & destWS.Name & "」", vbInformation
End Sub

优化说明 #

1. 效率提升核心：将所有数据一次性读入内存数组，处理完成后一次性写入工作表，避免了原代码中频繁的行插入/复制粘贴等IO操作，内存操作速度比工作表操作快几个数量级，完全支持1.5万行以上数据处理。
2. 逻辑兼容：完全保留原需求的判断逻辑，仅针对数据处理方式优化。
3. 安全保障：结果写入新工作表，不会覆盖原数据，避免误操作风险。
4. 进度反馈：保留状态栏进度显示，方便查看处理状态。

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