VBA拆分单元格内容到行运行过慢，2万行需10分钟如何优化？

性能瓶颈根因 #

你的代码运行慢的核心原因是频繁直接操作工作表对象：逐行遍历、逐次插入行、逐次复制写入，单次工作表操作的开销远高于内存操作，2万行数据下频繁IO自然耗时极长。

优化思路 #

• 放弃逐行操作工作表的模式，将所有有效数据一次性加载到内存数组中处理
• 预先统计所有拆分后得到的行总数，提前构建对应大小的结果数组，完全避免插入行的开销
• 所有拆分、行复制逻辑都在内存中完成，处理结束后仅执行1次工作表写入操作
• 额外关闭事件响应进一步降低不必要的性能损耗

优化后代码 #

Sub splitByColB_Optimized()
    Dim ws As Worksheet
    Dim sourceArr As Variant, resultArr As Variant
    Dim lastRow As Long, mCol As Long, totalRow As Long
    Dim i As Long, j As Long, k As Long, ar As Variant, col As Long
    
    ' 关闭不必要的系统设置
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlManual
    Application.EnableEvents = False
    
    Set ws = Worksheets("Export")
    mCol = 13 ' M列对应列号为13
    lastRow = ws.Cells(ws.Rows.Count, mCol).End(xlUp).Row
    ' 读取源数据到内存数组，可根据实际列数调整Z为你用到的最大列号
    sourceArr = ws.Range("A1:Z" & lastRow).Value
    
    ' 第一步：统计拆分后需要的总行数，提前分配结果数组空间
    totalRow = 0
    For i = 2 To lastRow
        ar = Split(sourceArr(i, mCol), ",")
        ' 过滤空值
        For j = 0 To UBound(ar)
            If Trim(ar(j)) <> "" Then totalRow = totalRow + 1
        Next
    Next
    ' 加上表头行
    ReDim resultArr(1 To totalRow + 1, 1 To UBound(sourceArr, 2))
    
    ' 第二步：填充表头
    For j = 1 To UBound(sourceArr, 2)
        resultArr(1, j) = sourceArr(1, j)
    Next
    
    ' 第三步：处理每行数据拆分，填充结果数组
    k = 2 ' 结果数组当前写入行号，从第二行开始跳过表头
    For i = 2 To lastRow
        ar = Split(sourceArr(i, mCol), ",")
        For j = 0 To UBound(ar)
            If Trim(ar(j)) <> "" Then
                ' 先复制整行原有数据
                For col = 1 To UBound(sourceArr, 2)
                    resultArr(k, col) = sourceArr(i, col)
                Next
                ' 替换M列为拆分后的单个值
                resultArr(k, mCol) = Trim(ar(j))
                k = k + 1
            End If
        Next
    Next
    
    ' 第四步：清空原有数据，一次性写入结果
    ws.Cells.Clear
    ws.Range("A1").Resize(UBound(resultArr, 1), UBound(resultArr, 2)).Value = resultArr
    ' 自动适配列宽（可选）
    ws.UsedRange.Columns.AutoFit
    
    MsgBox "操作完成，共生成 " & totalRow & " 行数据"
    
    ' 恢复系统设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic
    Application.EnableEvents = True
End Sub

效果说明 #

优化后的代码所有计算逻辑都在内存中完成，仅和工作表做2次交互（读数据、写数据），2万行原始数据的处理耗时可以从10分钟压缩到10秒以内。如果你的数据列数多于Z列，把代码中sourceArr = ws.Range("A1:Z" & lastRow).Value里的Z修改为你实际用到的最大列号即可。

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