工作表拆分

Sub 工作表拆分()
    '----------------------------------------------------
     '自定义各数据类型
    Dim Splitcol, Headrow, Endrow, rng As Range
    Dim Colnum As Integer, Head_count As Byte, End_count As Byte, Arr, Lastrow, i, Shtindex, Only As New Collection
    Dim Msg, New_wk
    
    On Error Resume Next
    '-----------------------------------------------------
    '指定需要的拆分条件列
    Set Splitcol = Application.InputBox("选择整列\或所在的任意单元格均可", "选择指定拆分条件的所在列", Type:=8)
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub
    If WorksheetFunction.CountA(Splitcol.EntireColumn) = 0 Then MsgBox "选择的列内容为空": Exit Sub
    '-----------------------------------------------------
    '设置标题行和尾部
    Set Headrow = Application.InputBox("选择整个行区域\或行所在区域的任意单元格均可", "选择标题行", Type:=8)
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub
    Head_count = Headrow.Rows.Count
    If Head_count >= Splitcol.Parent.UsedRange.Rows.Count Then Exit Sub
    
    Set Endrow = Application.InputBox("选择整个行区域\或行所在区域的任意单元格均可", "选择尾行", Type:=8)
    If Err.Number > 0 Then MsgBox "未选择内容": Exit Sub
    End_count = Endrow.Rows.Count
    If End_count >= Splitcol.Parent.UsedRange.Rows.Count Then Exit Sub
    
    On Error GoTo 0
    
    Msg = MsgBox("选择是—拆分为工作表" & Chr(10) & "选择否—拆分为工作薄", vbYesNo, "自定义拆分类型")
    
    With Splitcol.Parent
        Colnum = Splitcol.Column
        Lastrow = .UsedRange.Rows.Count
        
        '-------------------------------------------------
        '对需要拆分的条件列的值剔除重复值，利用Colection有序集合的成员不能存在重复内容的作用
        Arr = .Range(.Cells(Head_count + 1, Colnum), .Cells(Lastrow - End_count, Colnum))
        On Error Resume Next
        For i = 1 To Lastrow - Head_count
            If Len(Arr(i, 1)) > 0 Then Only.Add CStr(Arr(i, 1)), CStr(Arr(i, 1))
        Next i
        
        
        Application.ScreenUpdating = False '关闭屏幕更新，加快执行速度
        Application.DisplayAlerts = False  '关闭显示特定的警告和消息，删除已经存在相同名字的工作表时，不弹出消息
        
    If Msg = vbYes Then   '判断不同的拆分类型
        '拆分为工作表
        For i = 1 To Only.Count
            Err.Clear
            Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            Sheets(Sheets.Count).Name = Only(i)
            If Err.Number > 0 Then Sheets(Only(i)).Delete: Sheets(Sheets.Count).Name = Only(i)
        Next i
        
        '------------------------------------------------
        '利用筛选、复制可见内容的方式，分别将表格的内容拆分到各分表中
        .AutoFilterMode = False
        For i = 1 To Only.Count
            .Range(.Cells(Head_count, 1), .Cells(Lastrow - End_count, Colnum)).AutoFilter Field:=Colnum, Criteria1:=Only(i)
            .Range(.Cells(Lastrow - End_count + 1, 1), .Cells(Lastrow, Colnum)).EntireRow.Hidden = False
            .UsedRange.SpecialCells(xlCellTypeVisible).Copy
            
            ThisWorkbook.Sheets(Only(i)).Paste
            ThisWorkbook.Sheets(Only(i)).Cells.EntireColumn.AutoFit
            
        Next i
        .AutoFilterMode = False
      
      Else
      '拆分为工作薄
        .AutoFilterMode = False
        For i = 1 To Only.Count
            Err.Clear
            Set New_wk = Workbooks.Add
            New_wk.SaveAs Filename:=ThisWorkbook.Path & "\" & Only(i)
            
             .Range(.Cells(Head_count, 1), .Cells(Lastrow, Colnum)).AutoFilter Field:=Colnum, Criteria1:=Only(i)
             .Range(.Cells(Lastrow - End_count + 1, 1), .Cells(Lastrow, Colnum)).EntireRow.Hidden = False
            .UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=Workbooks(Only(i) & ".xlsx").Sheets(1).Range("a1")
            
            Workbooks(Only(i) & ".xlsx").Sheets(1).Cells.EntireColumn.AutoFit
            Workbooks(Only(i) & ".xlsx").Save
            Workbooks(Only(i) & ".xlsx").Close
            
        Next i
        .AutoFilterMode = False
      End If
        
        
   End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    ThisWorkbook.Save
    MsgBox "拆分完毕"

End Sub
1：将工作表依据某列的内容拆分成一个工作薄的多个工作表
2：将工作表依据某列的内容拆分成多个工作薄的单个工作表
3：表格批量分解
源码视频演示
工作表拆分

目录
