Excel-VBA把工作薄中的工作表拆分独立工作薄

应用场景

把工作薄的工作表拆分为独立的工作薄

知识要点

1：Application.FileDialog(msoFileDialogFolderPicker) 通过对话框选择存放路径

2：Workbook.SaveAs 方法 在另一不同文件中保存对工作簿所做的更改。

3：.Find('*]*'!' 查找工作表中是否存在外部引用，如有则转换为值

4：Sheets.Copy(Before, After) 方法 将工作表复制到工作簿的另一位置,如果既不指定 Before 也不指定 After，则将新建一个工作簿，其中包含复制的工作表。

5：Shell 函数 执行一个可执行文件 Shell 'EXPLORER.EXE'  用EXPLORER.EXE 打开文件夹

6：explorer.exe是Windows程序管理器或者文件资源管理器，它用于管理Windows图形壳，包括桌面和文件管理

Sub 把工作薄拆分为单个工作表()

    On Error Resume Next

    Dim Pathstr As String, i As Long, Activewb As String, Cell As Range, Firstaddress As String

    With Application.FileDialog(msoFileDialogFolderPicker)

        '创建文件对话框的实例

        If .Show Then  '如果在对话框中单击了 确定 按钮

            Pathstr = .SelectedItems(1)  '将选定的路径赋予变量

        Else

            Exit Sub

        End If

    End With

    Pathstr = Pathstr & IIf(Right(Pathstr, 1) = '\', '', '\') '如果不是\，末尾添加\

    Application.ScreenUpdating = False

    Activewb = ActiveWorkbook.Name  '记录活动工作薄名

    For i = 1 To Sheets.Count '循环所有工作表

        Sheets(i).Copy  '复制工作表到新工作薄中(忽略了参数)

        '将工作薄另存，文件名由工作表觉得，而文件的后缀名则由excel程序的版本决定

        ActiveWorkbook.SaveAs Filename:=Pathstr & Workbooks(Activewb).Sheets(i).Name & IIf(Application.Version * 1 < 12, '.xls', '.xlsx'), FileFormat:=xlWorkbookDefault, CreateBackup:=False

        With ActiveSheet.UsedRange '引用已用区域

            '查找“=*]*'!”,也就是检查是否存在外部引用

            Set Cell = .Find('*]*'!', LookIn:=xlFormulas, searchorder:=xlByRows, lookat:=xlPart, MatchCase:=True)

            If Cell Is Nothing Then GoTo Line

            Firstaddress = Cell.Address  '记录第一个找到的地址

            Do

                Cell = Cell.Value   '将公式转换为数值

                Set Cell = .FindNext(Cell) '查找下一个

                If Cell Is Nothing Then Exit Do '如果未找到，退出循环

                If Cell.Address = Firstaddress Then Exit Do

            Loop

        End With

Line:

        ActiveWindow.Close '关闭窗口

        Workbooks(Activewb).Activate '激活待拆分的工作薄

    Next i

    Application.ScreenUpdating = True

    Shell 'EXPLORER.EXE' & Pathstr, vbNormalFocus '打开文件夹

End Sub