如何将多张工作表复制到单独的工作簿并保存

Question

对任何糟糕的编码或无知表示歉意，我是 VBA 的基本用户。

我有一个 WorkbookA，其中有 X 张可以每天更换的工作表。我拼凑了将活动工作表从 WorkbookA 复制到 WorkbookB、定义保存目录和名称、保存并关闭 WorkbookB 的代码。

我想遍历 WorkbookA 中的所有工作表，从活动工作表到最后一个工作表。我该怎么做呢？

Public Sub CopySheetToNewWorkbook()

    ActiveSheet.Copy

    Name = ActiveSheet.Name & ".xls"
    Path = "MyPath\"

    ActiveWorkbook.SaveAs (Path & Name)
    ActiveWorkbook.Close

End Sub

Answer 1

将工作表复制到单独的工作簿

谨慎使用，因为文件会在不询问的情况下被覆盖。

Option Explicit

Sub CopySheetToNewWorkbook()

    Const MyPath As String = "MyPath" ' Sub Folder Name of This Workbook's Path

    Dim ws As Worksheet               ' First Worksheet
    Dim i As Long                     ' Sheets Counter
    Dim SavePath As String            ' Save Path
    Dim SaveFullName As String        ' Save Full Name

    With ThisWorkbook
        Set ws = .ActiveSheet
        SavePath = .Path & Application.PathSeparator & MyPath _
          & Application.PathSeparator
        Application.ScreenUpdating = False
            For i = ws.Index To .Sheets.Count
                With .Sheets(i)
                    SaveFullName = SavePath & .Name & ".xls"
                    .Copy
                End With
                GoSub SaveAndClose
            Next i
        Application.ScreenUpdating = True
    End With

    MsgBox "Copied sheets to new workbooks.", vbInformation, _
      "New Workbooks Saved and Closed"

GoTo exitProcedure

' Save and close new workbook.
SaveAndClose:
    On Error GoTo NewWorkbookError ' e.g. if workbook with same name is open.
        With ActiveWorkbook
            ' Note: The two Application.DisplayAlerts lines prevent Excel
            '       complaining about e.g.:
            '   Overwrite if file exists.
            '   Save if data outside of FileFormat (Compatibility Checker).
            Application.DisplayAlerts = False
                .SaveAs SaveFullName, FileFormat:=xlExcel8
            Application.DisplayAlerts = True
            .Close False ' Close but do not save.
        End With
    On Error GoTo 0
Return

NewWorkbookError:
    ActiveWorkbook.Close False ' Close but do not save.
    MsgBox Err.Description, vbExclamation, "New Workbook Closed and Not Saved"
    Resume exitProcedure

exitProcedure:

End Sub

将工作表复制到单个工作簿

我开发此代码首先假设（误读了帖子）ActiveSheet 的名称中有某种日期。

谨慎使用，因为文件会在不询问的情况下被覆盖。

Sub CopySheetsToNewWorkbook()

    Const MyPath As String = "MyPath" ' Sub Folder Name of This Workbook's Path

    Dim ws As Worksheet               ' First Worksheet
    Dim SheetsGroup() As String       ' Sheets Group Array
    Dim SheetsDiff As Long            ' Sheets Difference
    Dim i As Long                     ' Sheets Array Elements (Columns) Counter
    Dim SavePath As String            ' Save Path
    Dim SaveName As String            ' Save Name

    ' Copy sheets from this workbook to new workbook.
    With ThisWorkbook
        ' Define First Worksheet, Save Name and Save Path.
        Set ws = .ActiveSheet
        SaveName = ws.Name & ".xls"
        SavePath = .Path & Application.PathSeparator & MyPath _
          & Application.PathSeparator & SaveName
        ' Write sheet names to Sheets Group Array.
        ReDim SheetsGroup(.Sheets.Count - ws.Index)
        SheetsDiff = .Sheets.Count - ws.Index
        For i = 0 To SheetsDiff
            SheetsGroup(i) = .Worksheets(i + SheetsDiff - 1).Name
        Next i
        ' Copy sheets from Sheets Group Array to new workbook (ActiveWorkbook).
        .Sheets(SheetsGroup).Copy
    End With

    ' Save and close New Workbook.
    On Error GoTo NewWorkbookError ' e.g. if workbook with same name is open.
        With ActiveWorkbook
            ' Note: The two Application.DisplayAlerts lines prevent Excel
            '       from complaining about e.g.:
            '   Overwrite if file exists.
            '   Save if data outside of FileFormat (Compatibility Checker).
            Application.DisplayAlerts = False
                .SaveAs SavePath, FileFormat:=xlExcel8
            Application.DisplayAlerts = True
            .Close False ' Close but do not save.
        End With
    On Error GoTo 0

    MsgBox "Copied sheets to new workbook.", vbInformation, _
      "New Workbook Saved and Closed"

GoTo exitProcedure

NewWorkbookError:
    ActiveWorkbook.Close False ' Close but do not save.
    MsgBox Err.Description, vbExclamation, "New Workbook Closed and Not Saved"
    Resume exitProcedure

exitProcedure:

End Sub

关闭工作簿

有几次我在开发之前的代码时打开了十多个工作簿，所以我写了这个节省时间的小工具。

谨慎使用它，因为工作簿将在不保存更改的情况下关闭。

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:    Closes all workbooks except this one (ThisWorkbook).             '
' Remarks:    Be careful because all the changes on those other workbooks      '
'             will be lost.                                                    '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub closeWorkbooks()
    Dim wb As Workbook
    Application.ScreenUpdating = False
        For Each wb In Workbooks
            If Not wb Is ThisWorkbook Then wb.Close False
        Next wb
    Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''