VBA需求：根据列值拆分表格行并按类型创建对应工作表

方法一：用Power Query批量处理（推荐，无需代码） #

Power Query是Excel内置的批量数据处理工具，比逐行循环快几个量级，适合非代码用户：

1. 选中你的数据区域（包含表头columnA和columnB）
2. 点击「数据」选项卡 → 「从表格/区域」（Excel 2016及以后版本；旧版本找「获取和转换」组的对应入口）
3. 在Power Query编辑器中，直接点击「主页」→「关闭并上载至」，选择「仅创建连接」后确认
4. 在Excel左侧「查询和连接」面板中，右键刚才创建的连接 → 「加载到」
5. 在弹出的对话框中：
   • 选择「表」
   • 勾选「将数据加载到多个工作表」
   • 「依据列」选择columnA
6. 确认后，Excel会自动按columnA的每种类型创建对应工作表，并批量填充匹配数据

方法二：优化后的VBA代码（适合自动化场景） #

如果你需要用VBA实现，核心是减少工作表交互、用内存处理数据，避免逐行粘贴的低效操作：

Sub SplitDataToSheets()
    Dim wsSource As Worksheet
    Dim lastRow As Long
    Dim dataArr As Variant
    Dim dict As Object
    Dim i As Long
    Dim key As Variant
    Dim wsNew As Worksheet
    
    ' 指定源工作表，替换成你的数据所在表名
    Set wsSource = ThisWorkbook.Worksheets("源数据")
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    dataArr = wsSource.Range("A1:B" & lastRow).Value ' 一次性读取数据到内存数组
    
    ' 用字典存储各类型对应的行数据
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 遍历数组完成数据分组
    For i = 2 To UBound(dataArr)
        key = dataArr(i, 1)
        If Not dict.Exists(key) Then
            ' 首次存入该类型：表头+当前行
            dict(key) = Array(Array(dataArr(1, 1), dataArr(1, 2)), Array(dataArr(i, 1), dataArr(i, 2)))
        Else
            ' 追加当前行到对应类型的数组
            dict(key) = JoinArrays(dict(key), Array(dataArr(i, 1), dataArr(i, 2)))
        End If
    Next i
    
    ' 关闭Excel耗时操作，提升速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
    ' 创建工作表并写入分组数据
    For Each key In dict.Keys
        ' 检查工作表是否已存在，存在则清空
        On Error Resume Next
        Set wsNew = ThisWorkbook.Worksheets(CStr(key))
        On Error GoTo 0
        If wsNew Is Nothing Then
            Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            wsNew.Name = CStr(key)
        Else
            wsNew.Cells.Clear
        End If
        
        ' 一次性写入所有数据到新表
        wsNew.Range("A1").Resize(UBound(dict(key)) + 1, 2).Value = TransposeArray(dict(key))
        Set wsNew = Nothing
    Next key
    
    ' 恢复Excel默认设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "拆分完成！"
End Sub

' 辅助函数：合并数组
Function JoinArrays(arr1 As Variant, arr2 As Variant) As Variant
    Dim tempArr() As Variant
    Dim i As Long
    ReDim tempArr(UBound(arr1) + 1)
    For i = 0 To UBound(arr1)
        tempArr(i) = arr1(i)
    Next i
    tempArr(UBound(tempArr)) = arr2
    JoinArrays = tempArr
End Function

' 辅助函数：转置数组适配工作表写入格式
Function TransposeArray(arr As Variant) As Variant
    Dim tempArr() As Variant
    Dim i As Long, j As Long
    ReDim tempArr(1 To UBound(arr) + 1, 1 To 2)
    For i = 0 To UBound(arr)
        For j = 1 To 2
            tempArr(i + 1, j) = arr(i)(j - 1)
        Next j
    Next i
    TransposeArray = tempArr
End Function

VBA代码的优化点： #

• 一次性读取所有数据到内存数组，避免反复读写工作表（这是提速的核心）
• 用Scripting.Dictionary快速分组数据，比逐行判断效率高
• 关闭屏幕更新、事件触发和自动计算，减少Excel后台开销
• 批量写入数据到新工作表，替代逐行粘贴的低效操作

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