Excel中用VBA将根据列内容分割成多个工作表

Sub 工作表拆分2() '通过筛选方法完成需求，速度快，但当有合并单元格时就不能用。读者可以根据实际情况选用
    Dim SplitCol As String, ColNum As Integer, HeadRows As Byte, arr, lastrow, i, ShtIndex, only As New Collection, Rng As Range
    SplitCol = "c"  '指定拆分条件所在列
    HeadRows = 2   '指定标题行数，该区域不参与拆分
    If HeadRows >= ActiveSheet.UsedRange.Rows.Count Then Exit Sub '如果指定的标题行大于已用区域行数则退出程序
    ColNum = Cells(1, SplitCol).Column  '将列标转换成数字
    lastrow = ActiveSheet.UsedRange.Rows.Count  '获取当前表已用区域的行数
    arr = Range(Cells(HeadRows + 1, SplitCol), Cells(lastrow, SplitCol)).Value  '将拆分列的数据赋与变量arr
    On Error Resume Next
    If ActiveSheet.FilterMode Then Cells.AutoFilter    '如果处于筛选模式，那么去除筛选模式
    For i = 1 To lastrow - HeadRows  '遍历arr所有数据
        '提取其中的不重复值
        If Len(arr(i, 1)) > 0 Then only.Add CStr(arr(i, 1)), CStr(arr(i, 1))
    Next i
    ShtIndex = ActiveSheet.Index  '获取当前表位置
    On Error Resume Next
    For i = 1 To only.Count
        Debug.Print Sheets(only(i)).Name  '获取与only对象中每个元素同名的工作表名（用意为判断是否存在该工作表）
        If Err = 0 Then MsgBox "当前工作簿已存在与待拆分项目同名的工作表“" & only(i) & "”，暂无法拆分", 64, "友情提示": Exit Sub
        Err.Clear
    Next i
    Application.ScreenUpdating = False  '关闭屏幕更新，加快执行速度
    Application.Calculation = xlCalculationManual  '调为手动计算，加快执行速度
    For i = 1 To only.Count  '创建工作表，表的数量与表名由only对象中不重复值而定
        Sheets.Add After:=Sheets(Sheets.Count)  '创建
        Sheets(Sheets.Count).Name = only(i)    '命名
        Sheets(ShtIndex).Rows("1:" & HeadRows).Copy Sheets(Sheets.Count).Cells(1, 1)  '复制标题
    Next i
Sheets(ShtIndex).Select   '返回待拆分工作表
    For i = 1 To only.Count '遍历Collection对象所有成员。Collection对象包括了所有拆分条件，即工作表名
       '对拆分条件所在列进行筛选，筛选条件是Collection对象中的成员，本例中是部门名称
        Range(Cells(HeadRows, SplitCol), Cells(lastrow, SplitCol)).AutoFilter Field:=1, Criteria1:=only(i)
        Set Rng = Range(Cells(HeadRows + 1, SplitCol), Cells(Rows.Count, SplitCol).End(xlUp)).SpecialCells(xlCellTypeVisible).EntireRow '引用筛选后的数据（整行）
        With Sheets(only(i)).UsedRange.Rows(Sheets(only(i)).UsedRange.Rows.Count + 1) '引用拆分后的工作表的已用区域下一行
            Rng.Copy .Cells(1)  '第一次复制，复制所有数据，仅取其格式
            .Cells = Rng.Value  '第二次复制，仅复制数值
        End With
    Next
     Cells.AutoFilter '去除筛选模式
    Application.ScreenUpdating = True  '恢复屏幕更新
    Application.Calculation = xlCalculationAutomatic  '恢复自动计算
    MsgBox "拆分完毕！", 64, "友情提示"
End Sub