Excel-VBA依据某列作为拆分条件，对工作表进行拆分

应用场景

对工作表依据某列作为拆分条件，进行拆分

知识要点

1：通过集合，对条件列去除重复值，作为拆分的工作表名

2：逐行复制符合对应表名的整行，黏贴到对应工作表中

3：Range.AutoFilter 方法  使用“自动筛选”筛选一个列表

4：SpecialCells(xlCellTypeVisible)对筛选后的非隐西藏域复制，黏贴到对应的工作中

Sub 逐行复制方法拆分工作表() '逐行复制，速度偏慢，通用性好

    Dim Splitcol As String, Colnum As Integer, Headrows As Byte, Arr, Lastrow, i, Shtindex, Only As New Collection

    Splitcol = 'B' '指定拆分条件所在列，可以根据实际情况修改列标

    Headrows = 2 '指定标题行数，该区域不参与拆分

    '如果指定的标题行大于已用区域行数则退出程序

    If Headrows >= ActiveSheet.UsedRange.Rows.Count Then Exit Sub

    Colnum = Cells(1, Splitcol).Column '将列标转换为数字

    Lastrow = ActiveSheet.UsedRange.Rows.Count  '获取当前表已用区域的行数

    '将拆分列的数据赋予变量arr

    Arr = Range(Cells(Headrows 1, Colnum), Cells(Lastrow, Colnum)).Value

    On Error Resume Next

    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

        If Err = 0 Then MsgBox '当前工作薄中已存在与待拆分项目同名的工作表' & Only(i) & '暂无法拆分': Exit Sub

        Err.Clear

    Next i

    Application.ScreenUpdating = False '关闭屏幕更新，加快执行速度

    Application.Calculation = xlCalculationManual '调为手动计算，加快执行速度

    For i = 1 To Only.Count

        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 = Headrows 1 To Lastrow '逐行复制数据

        If Len(Cells(i, Splitcol)) > 0 Then  '排除空值

            With Sheets(Cells(i, Splitcol).Text).UsedRange.Rows(Sheets(Cells(i, Splitcol).Text).UsedRange.Rows.Count 1)

                Rows(i).Copy .Cells(1)

                .Cells = Rows(i & ':' & i).Value '第二行复制，仅复制数值

            End With

        End If

    Next i

    Application.ScreenUpdating = True '恢复屏幕更新

    Application.Calculation = xlCalculationAutomatic '恢复自动计算

    MsgBox '拆分完毕'

End Sub

Sub 用筛选方法拆分工作表() '用筛选的方法

    Dim Splitcol As String, Colnum As Integer, Headrows As Byte, Arr, Lastrow, i, Shtindex, Only As New Collection

    Splitcol = 'B' '指定拆分条件所在列，可以根据实际情况修改列标

    Headrows = 2 '指定标题行数，该区域不参与拆分

    '如果指定的标题行大于已用区域行数则退出程序

    If Headrows >= ActiveSheet.UsedRange.Rows.Count Then Exit Sub

    Colnum = Cells(1, Splitcol).Column '将列标转换为数字

    Lastrow = ActiveSheet.UsedRange.Rows.Count  '获取当前表已用区域的行数

    '将拆分列的数据赋予变量arr

    Arr = Range(Cells(Headrows 1, Colnum), Cells(Lastrow, Colnum)).Value

    On Error Resume Next

    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

        If Err = 0 Then MsgBox '当前工作薄中已存在与待拆分项目同名的工作表' & Only(i) & '暂无法拆分': Exit Sub

        Err.Clear

    Next i

    Application.ScreenUpdating = False '关闭屏幕更新，加快执行速度

    Application.Calculation = xlCalculationManual '调为手动计算，加快执行速度

    For i = 1 To Only.Count

        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对象中的成员，本例中是部门名称

        Range(Cells(Headrows, Splitcol), Cells(Lastrow, Splitcol)).AutoFilter fileld:=1, criterial:=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 '拆分完毕'

End Sub