VBA学习练习-拆分成多个工作簿

实际运用过程中，尤其是运营岗，经常收到一份总的报表，需要分区域下发，可以用以下VBA将数据按指定列拆分成多个工作簿

原理：

1、拆分成多个sheet

2、根据sheet建工作表并copy

3、删除sheet

Sub 拆分成多个工作簿()
'将报表按指定列分类并保存到各工作表中
Dim i, c As Long, bj As String, rng As Range, arr(), myrows, lc As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
myrows = Application.InputBox("请输入内容从第几行开始")    '分类处理的第一条记录在第几行
i = myrows
c = Application.InputBox("请输入拆分列号")
arr = Range("A1").CurrentRegion
lc = UBound(arr, 2)

bj = Worksheets(1).Cells(i, c).Value
Do While bj <> ""                                                 '直到成绩表中C列的单元格为空单元格时终止循环
    
    On Error Resume Next                                          '当没有对应工作表时，忽略下一行代码引起的运行错误
    If Worksheets(bj) Is Nothing Then                                                                   '判断是否已有工作表，没有就新建并写入表头
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = bj
        Worksheets(1).Cells(1, "A").Resize(myrows - 1, lc).Copy Worksheets(bj).Cells(1, "A")
    End If
    
    Set rng = Worksheets(bj).Range("A1048576").End(xlUp).Offset(1, 0) '确定班级工作表中A列的第一个空单元格，作为写入成绩记录的目标区域
    Worksheets(1).Cells(i, "A").Resize(, lc).Copy rng
    i = i + 1
    bj = Worksheets(1).Cells(i, c).Value
Loop

'MsgBox "已分类到各sheetta"

Dim folder As String
folder = ThisWorkbook.Path & "\新建文件夹"            		'保存工作簿文件的目录
If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder		'选择是否新建该文件夹
Dim sht As Worksheet
For Each sht In Worksheets
    sht.Copy												'复制工作表到工作簿
    ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xlsx"	'保存工作簿并命名
    ActiveWorkbook.Close
Next

Dim sht1 As Worksheet
For Each sht1 In Worksheets
    If sht1.Name <> Worksheets(1).Name Then
        sht1.Delete
    End If
Next

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub