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
 ' 創(chuàng)建一個字典來存儲唯一值和對應的行
 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
   ' 創(chuàng)建一個新的工作表
   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