vba拆分工作簿的工作表至多个独立工作簿

Sub DetachWorkbook()
    On Error Resume Next
    Dim pathStr As String, i As Long, activeWb 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
        If Sheets(i).Name <> "Sheet1" Then
            Sheets(i).Copy
            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
        End If
    Next i

    Application.ScreenUpdating = True
    Shell "Explorer.exe " & pathStr, vbNormalFocus
End Sub