VBA按记录类型拆分海量数据代码优化求助

嗨，我来帮你解决这个效率问题！15万行数据跑50分钟确实太慢了，大概率是你的代码存在重复遍历数据源或者逐行复制粘贴这类低效操作，咱们一步步来优化：

先分析你当前代码的核心问题 #

如果每个模块（module1-module6）都单独遍历一遍Raw Data表筛选对应类型，等于要把15万行数据重复扫6次，这本身就浪费了大量时间；再加上逐行复制单元格的操作，在VBA里本来就属于慢操作，数据量一大就会彻底拖慢速度。

给你几个高效优化方案（按效果排序） #

1. 一次性遍历+数组批量写入（最推荐）

只遍历Raw Data表一次，把不同类型的数据分别存入对应数组，最后一次性写入目标工作表。这种方法把遍历次数从6次降到1次，而且数组操作比单元格操作快几十倍。

示例代码如下：

Sub SplitDataByType()
    Dim wsRaw As Worksheet, wsProp As Worksheet, wsPppp As Worksheet, wsAbcd As Worksheet
    Dim rawData As Variant, propData As Variant, ppppData As Variant, abcdData As Variant
    Dim rawRowCount As Long, i As Long, j As Long
    Dim propIdx As Long, ppppIdx As Long, abcdIdx As Long
    Dim lastRow As Long, lastCol As Long
    
    ' 关闭Excel不必要的功能，减少后台开销
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' 初始化工作表对象
    Set wsRaw = ThisWorkbook.Sheets("Raw Data")
    Set wsProp = ThisWorkbook.Sheets("PROP")
    Set wsPppp = ThisWorkbook.Sheets("PPPP")
    Set wsAbcd = ThisWorkbook.Sheets("ABCD")
    ' 剩下3个类型的工作表也按同样方式初始化
    
    ' 一次性读取Raw Data的所有数据到数组（速度极快）
    lastRow = wsRaw.Cells(wsRaw.Rows.Count, "B").End(xlUp).Row ' B列是记录类型列
    lastCol = wsRaw.Cells(2, wsRaw.Columns.Count).End(xlToLeft).Column
    rawData = wsRaw.Range("A2:" & wsRaw.Cells(lastRow, lastCol).Address).Value
    
    rawRowCount = UBound(rawData, 1)
    ' 初始化目标数组，先按最大行数定义，最后再裁剪
    ReDim propData(1 To rawRowCount, 1 To lastCol)
    ReDim ppppData(1 To rawRowCount, 1 To lastCol)
    ReDim abcdData(1 To rawRowCount, 1 To lastCol)
    
    propIdx = 1
    ppppIdx = 1
    abcdIdx = 1
    
    ' 一次性遍历所有数据，按类型分类存入对应数组
    For i = 1 To rawRowCount
        Select Case rawData(i, 2) ' 第2列对应原代码的B列（记录类型列）
            Case "PROP"
                For j = 1 To lastCol
                    propData(propIdx, j) = rawData(i, j)
                Next j
                propIdx = propIdx + 1
            Case "PPPP"
                For j = 1 To lastCol
                    ppppData(pppppIdx, j) = rawData(i, j)
                Next j
                ppppIdx = ppppIdx + 1
            Case "ABCD"
                For j = 1 To lastCol
                    abcdData(abcdIdx, j) = rawData(i, j)
                Next j
                abcdIdx = abcdIdx + 1
            ' 剩下3种记录类型的Case分支也按同样方式添加
        End Select
    Next i
    
    ' 清空目标工作表的旧数据（按需调整起始位置，比如你原代码的A9）
    wsProp.Range("A9:" & wsProp.Cells(wsProp.Rows.Count, lastCol).Address).ClearContents
    wsPppp.Range("A9:" & wsPppp.Cells(wsPppp.Rows.Count, lastCol).Address).ClearContents
    wsAbcd.Range("A9:" & wsAbcd.Cells(wsAbcd.Rows.Count, lastCol).Address).ClearContents
    
    ' 把数组批量写入目标工作表
    If propIdx > 1 Then
        wsProp.Range("A9").Resize(propIdx - 1, lastCol).Value = propData
    End If
    If ppppIdx > 1 Then
        wsPppp.Range("A9").Resize(pppppIdx - 1, lastCol).Value = ppppData
    End If
    If abcdIdx > 1 Then
        wsAbcd.Range("A9").Resize(abcdIdx - 1, lastCol).Value = abcdData
    End If
    ' 剩下3个工作表的写入逻辑同上
    
    ' 恢复Excel正常功能
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    
    MsgBox "数据拆分完成！"
End Sub

2. 使用AutoFilter批量筛选复制

如果不想用数组，也可以用AutoFilter一次性筛选出对应类型，再批量复制粘贴，比逐行复制快很多：

Sub FilterAndCopyBatch()
    Dim wsRaw As Worksheet, wsTarget As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim targetStart As Range
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set wsRaw = ThisWorkbook.Sheets("Raw Data")
    lastRow = wsRaw.Cells(wsRaw.Rows.Count, "B").End(xlUp).Row
    lastCol = wsRaw.Cells(2, wsRaw.Columns.Count).End(xlToLeft).Column
    
    ' 处理PROP类型
    Set wsTarget = ThisWorkbook.Sheets("PROP")
    Set targetStart = wsTarget.Range("A9")
    ' 清空目标区域旧数据
    wsTarget.Range(targetStart, wsTarget.Cells(wsTarget.Rows.Count, lastCol).Address).ClearContents
    ' 筛选PROP类型并复制
    wsRaw.Range("A1:" & wsRaw.Cells(lastRow, lastCol).Address).AutoFilter Field:=2, Criteria1:="PROP"
    wsRaw.Range("A2:" & wsRaw.Cells(lastRow, lastCol).Address).SpecialCells(xlCellTypeVisible).Copy targetStart
    
    ' 处理PPPP、ABCD等类型，只需修改Criteria1和wsTarget即可
    ' ...
    
    ' 关闭筛选
    wsRaw.AutoFilterMode = False
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub

这个方法比逐行复制快，但效率还是不如数组方案，不过已经能把时间压缩到几分钟以内。

3. 其他细节优化

• 避免在循环里用Select、Activate操作，直接对工作表/单元格对象进行操作
• 把重复的初始化逻辑（比如关闭Excel功能）提取到公共代码块，不要每个模块都写一遍
• 预先设置好目标工作表的格式，不要在代码里重复设置格式增加开销

用数组方案的话，15万行数据基本能在1分钟内完成，完全解决你50分钟的痛点！

备注：内容来源于stack exchange，提问作者user2251216