拆分工作表-一表变多簿（Excel代码集团）

数据源如图，共7列N行，第一列为拆分依据，将一个工作表拆分成N个工作簿（Excel文件）。

代码：

Sub Sample()
Application.DisplayAlerts = False
Dim i As Long, j As Long
Dim MyTitle, MyArr
Dim MyShN As String
i = Cells(Rows.Count, 1).End(xlUp).Row
With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add2 Key:=Range("a1:a" & i), Order:=xlAscending
    .SetRange Range("a1:h" & i)
    .Header = xlYes
    .Apply
End With
Do
    MyTitle = Range("a1:h1")
    i = Cells(Rows.Count, 1).End(xlUp).Row
    j = Application.CountIf(Range("a:a"), Cells(i, 1))
    MyArr = Cells(i - j + 1, 1).Resize(j, 8)
    MyShN = Cells(i, 1)
    Sheets.Add after:=ActiveSheet
    With Sheets(2)
        .Range("a1:h1") = MyTitle
        .Range("a2:h" & j + 1) = MyArr
        .Name = MyShN
        .Cells.EntireColumn.AutoFit
        .Move
    End With
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Sheets(1).Name & ".xlsx"
    ActiveWindow.Close
    Sheets(1).Select
    Cells(i - j + 1, 1).Resize(j, 1).EntireRow.Delete
Loop Until i - j = 1
Application.DisplayAlerts = True
End Sub