Sub SplitDataByColumnA()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim lastRow As Long
Dim lastCol As Long
Dim i As Long
Dim dict As Object
Dim key As Variant
Dim rng As Range
Dim cell As Range
' 设置源工作表
Set wsSource = ThisWorkbook.Sheets("Sheet1") ' 修改为你的工作表名称
' 获取源工作表的最后一行和最后一列
lastRow = wsSource.Cells(wsSource.rows.Count, 1).End(xlUp).Row
lastCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
' 创建一个字典来存储唯一值和对应的行
Set dict = CreateObject("Scripting.Dictionary")
' 遍历列A中的数据
For Each cell In wsSource.Range("A2:A" & lastRow)
If Not dict.exists(cell.Value) Then
dict.Add cell.Value, cell.Row
Else
dict(cell.Value) = dict(cell.Value) & "," & cell.Row
End If
Next cell
' 遍历字典中的每个键(唯一值)
For Each key In dict.keys
' 创建一个新的工作表
Set wsDest = ThisWorkbook.Sheets.Add
wsDest.Name = key ' 将工作表命名为当前键值
' 复制标题行到新工作表
wsSource.rows(1).Copy Destination:=wsDest.rows(1)
' 获取当前键值对应的行号
Dim rows As Variant
rows = Split(dict(key), ",")
' 复制对应的行到新工作表
For i = LBound(rows) To UBound(rows)
wsSource.rows(rows(i)).Copy Destination:=wsDest.rows(wsDest.Cells(wsDest.rows.Count, 1).End(xlUp).Row + 1)
Next i
Next key
' 释放对象
Set dict = Nothing
Set wsSource = Nothing
Set wsDest = Nothing
MsgBox "数据拆分完成!"
End Sub