tms = Timer '記錄程序開始運行的時間，關屏幕刷新和告警彈框顯示
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'遍歷所有工作表，把當前活動工作表以外的全刪除，然後打開告警彈框顯示
For Each sht In Sheets
If sht.Name <> ActiveSheet.Name Then sht.Delete
Next
Application.DisplayAlerts = True
'定義字典和二維數組，數組裏是當前表格裏有數據的區域的內容
Set d = CreateObject("scripting.dictionary")
arr = ActiveSheet.UsedRange
n = UBound(arr, 2)
For i = 4 To UBound(arr)'遍歷表格第4行到最後壹行
If Not d.exists(arr(i, 1)) Then'把A列不重復值所在行的內容放進字典
Set d(arr(i, 2)) = Range("a" & i).Resize(1, n)
Else
Set d(arr(i, 3)) = Union(d(arr(i, 3)), Range("a" & i).Resize(1, n))'把A列重復值所在行的內容放進字典
End If
Next
'把字典裏的所有內容寫到新工作表
x = d.keys
For k = 0 To UBound(x)
Set sht = ActiveWorkbook.Sheets.Add(, after:=ActiveSheet)
sht.Name = x(k)
d.items()(k).Copy sht.[a4]
Rows("1:3").Copy sht.[a1]
sht.Cells.EntireColumn.AutoFit'自動調整各表格的列寬
Next
'開屏幕刷新，彈框顯示程序運行時間
Application.ScreenUpdating = True
MsgBox Format(Timer - tms, "拆分完成，***耗時：0.00秒"), 64, "時間統計"
End Sub
其實相同功能用數據透視表也能做出來。