编写Macro：按A列索引拆分数据至独立工作表（各表A列值唯一）

以下是符合需求的VBA宏代码，能将按A列排序的数据拆分至多个工作表，保证每个工作表内A列的索引值唯一：

Sub SplitDataToSheets()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim key As String
    Dim countDict As Object
    Dim sheetIndex As Integer
    
    ' 设置源工作表（可根据实际修改，比如改为Sheet1）
    Set wsSource = ActiveSheet
    ' 获取源数据最后一行
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    ' 创建字典用于记录每个A列值的出现次数
    Set countDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历数据行（假设第1行是表头，从第2行开始处理）
    For i = 2 To lastRow
        key = CStr(wsSource.Cells(i, "A").Value)
        ' 更新当前A列值的计数
        If countDict.Exists(key) Then
            countDict(key) = countDict(key) + 1
        Else
            countDict(key) = 1
        End If
        ' 计算目标工作表索引（从1开始）
        sheetIndex = countDict(key)
        
        ' 检查目标工作表是否存在，不存在则创建
        On Error Resume Next
        Set wsTarget = ThisWorkbook.Worksheets("Sheet_" & sheetIndex)
        On Error GoTo 0
        If wsTarget Is Nothing Then
            Set wsTarget = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            wsTarget.Name = "Sheet_" & sheetIndex
            ' 复制表头到新工作表
            wsSource.Rows(1).Copy Destination:=wsTarget.Rows(1)
        End If
        
        ' 复制当前行到目标工作表的最后一行
        wsSource.Rows(i).Copy Destination:=wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Offset(1, 0)
        ' 重置wsTarget对象
        Set wsTarget = Nothing
    Next i
    
    MsgBox "数据拆分完成！", vbInformation
End Sub

代码说明 #

• 字典countDict：用于跟踪每个A列值的出现次数，以此确定当前行要分配到第几个工作表
• 工作表创建逻辑：当需要的工作表不存在时，自动创建并命名为Sheet_1、Sheet_2...，同时复制源表的表头
• 数据复制：将每行数据复制到对应工作表的末尾，保证每个工作表内同一A列值只出现一次

使用注意事项 #

1. 确保源数据已经按A列完成排序，这样同一A列值的行是连续的，分配逻辑会更高效
2. 运行宏前请保存工作簿，避免数据丢失
3. 如果源表没有表头，可删除代码中复制表头的那一行，并将遍历起始行改为i = 1

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