使用VBA按类别将指定区域数据列表拆分至不同目标列

适用场景 #

• 数据源固定存放在A2:C50区域，A列包含3个唯一类别值
• 拆分后的3组数据需分别从D列、G列、J列起始位置存放，保留原表3列的结构

实现代码 #

Sub SplitDataByCategory()
    Dim ws As Worksheet
    Dim cateDict As Object
    Dim targetCols As Variant
    Dim i As Long, k As Long, endRow As Long
    Dim curCate As String
    
    ' 绑定工作表，可修改为指定表名如 Set ws = Sheets("数据表")
    Set ws = ActiveSheet
    ' 定义三个分组的起始列号：D=4, G=7, J=10
    targetCols = Array(4, 7, 10)
    ' 用字典存储唯一类别
    Set cateDict = CreateObject("Scripting.Dictionary")
    
    ' 清空目标区域旧数据，避免残留
    ws.Range("D:L").ClearContents
    
    ' 提取A列唯一类别
    For i = 2 To 50
        curCate = Trim(ws.Cells(i, 1).Value)
        If curCate <> "" And Not cateDict.Exists(curCate) Then
            cateDict.Add curCate, targetCols(cateDict.Count)
            ' 提取够3个类别就提前退出循环
            If cateDict.Count = 3 Then Exit For
        End If
    Next i
    
    ' 复制表头到三个分组的首行
    For k = 0 To 2
        ws.Cells(1, targetCols(k)).Resize(1, 3).Value = ws.Range("A1:C1").Value
    Next k
    
    ' 逐行遍历数据，按类别写入对应分组
    For i = 2 To 50
        curCate = Trim(ws.Cells(i, 1).Value)
        If curCate = "" Then GoTo NextLine
        ' 定位目标列的首个空行
        endRow = ws.Cells(ws.Rows.Count, cateDict(curCate)).End(xlUp).Row + 1
        ' 写入该行3列数据
        ws.Cells(endRow, cateDict(curCate)).Resize(1, 3).Value = _
            ws.Cells(i, 1).Resize(1, 3).Value
NextLine:
    Next i
    
    MsgBox "拆分完成，共处理" & cateDict.Count & "个类别数据", vbInformation
    
    ' 释放对象
    Set cateDict = Nothing
    Set ws = Nothing
End Sub

使用步骤 #

• 打开存放数据的Excel文件，按Alt+F11快捷键打开VBA编辑器
• 在左侧工程资源管理器中右键点击当前工作簿名称，选择「插入」-「模块」，将上述代码粘贴到弹出的模块代码窗口中
• 按F5运行名为SplitDataByCategory的宏即可完成拆分

调整说明 #

• 如果需要固定类别和列的对应关系，不需要自动按出现顺序匹配，可以注释掉提取类别的循环代码，手动给字典添加键值对，示例：

  ' 手动指定对应关系：类别名 -> 起始列号
  cateDict.Add "类别A", 4
  cateDict.Add "类别B", 7
  cateDict.Add "类别C", 10
  

• 如果原表没有表头，删除复制表头的对应代码块，同时把定位空行的逻辑从第2行开始计算即可
• 代码中已经加了Trim()处理前后空格，避免因为单元格值带不可见空格导致类别识别错误

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