Как скопировать несколько листов в отдельные книги и сохранить

Question

Приносим извинения за плохое кодирование или незнание. Я очень c пользователь VBA.

У меня есть WorkbookA, в которой есть X листов, которые могут меняться ежедневно. Я составил код, который скопирует активный лист из WorkbookA в WorkbookB, определит каталог и имя для сохранения, сохранит и закроет WorkbookB.

Я хочу l oop через все листы в WorkbookA, начиная с активного лист до последнего листа. Как я могу go сделать это?

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

Close Workbooks

Несколько раз при разработке предыдущего кода у меня было открыто более десяти книг, поэтому я написал эту небольшую экономию времени.

Используйте его с осторожностью, потому что книги будут закрыты без сохранения изменений.

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''