将每张图纸导出到单个文件

Option Explicit

Sub ExportSheets()
    
    Const PROC_TITLE As String = "Export Sheets"
    
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    
    Dim dFilePath As String: dFilePath = swb.Path
    
    If Len(dFilePath) = 0 Then
        MsgBox "The path cannot be determined." & vbLf & "Please save the " _
            & "workbook before using this procedure.", vbCritical, PROC_TITLE
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Dim dwb As Workbook, ssh As Object, sshCount As Long
    
    For Each ssh In swb.Sheets
        If ssh.Visible = xlSheetVisible Then ' sheet is visible
            ssh.Copy
            Set dwb = Workbooks(Workbooks.Count)
            Application.DisplayAlerts = False ' overwrite without confirmation
                dwb.SaveAs Filename:=dFilePath & "\" & ssh.Name
            Application.DisplayAlerts = False
            dwb.Close SaveChanges:=False
            sshCount = sshCount + 1
        'Else ' sheet is not visible; do nothing!?
        End If
    Next ssh

    Application.ScreenUpdating = True
    
    MsgBox sshCount & " sheet" & IIf(sshCount = 1, "", "s") _
        & " exported.", vbInformation, PROC_TITLE

End Sub