Есть ли способ сохранить рабочий лист при разделении нескольких рабочих листов на рабочие?то есть.как главная страница / сводный лист

Question

Мне удалось разделить рабочую книгу, содержащую несколько рабочих листов с различными данными о местоположении, на отдельные рабочие книги на основе значения в столбце (географическая ссылка), который прекрасно работает.Однако у меня есть первый лист, который помогает уточнить данные.Есть ли способ скопировать этот рабочий лист в разделенных рабочих книгах, пока он разделяется?

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

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

Sub Split_To_Workbook_and_Email()
'Working in 2013/2016
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
    Dim myOutlook As Object
    Dim myMailItem As Object
    Dim mySubject As String
    Dim myPath As String
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Prompt for Email Subject

    Set otlApp = CreateObject("Outlook.Application")

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ActiveWorkbook
    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "File Name" & Sourcewb.Name & " " & DateString
    MkDir FolderName
    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy
            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook
            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2016
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                End If
            End With
            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If
            'Save the new workbook, email it, and close it

        With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum, _
                        Password:="AreaXXX", _
                        WriteResPassword:=""

            End With
            myPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
            With Destwb
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh
    MsgBox "You can find the files in " & FolderName
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Answer 1

Попробуйте что-то вроде этого:

Sub SheetsToNewWorkbook()
    Dim SourceWB As Workbook, DestWB As Workbook
    Dim FrontPage As Worksheet, sht As Worksheet
    Set SourceWB = ThisWorkbook ' Or whatever Workbook object your source is
    Set FrontPage = SourceWB.Sheets("NameOfYourSummarySheet") ' Set the name
    Dim SheetsInNewWorkbook As Long ' Variable to store the current setting
    SheetsInNewWorkbook = Application.SheetsInNewWorkbook
    ' Create new folder to save the new files in
    Dim DateString As String, FolderName As String
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "File Name" & SourceWB.Name & " " & DateString ' You might want to change these
    MkDir FolderName ' This will cause an error if the dir already exists
    ' Determine the Excel version and file extension/format
    Dim FileExtStr As String, FileFormatNum As Long
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143 ' Excel 97-2003
    Else
        FileExtStr = ".xlsx": FileFormatNum = 51 'Excel 2007-2016
    End If
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .DisplayAlerts = False
        .SheetsInNewWorkbook = 1
    End With
    '
    For Each sht In SourceWB.Worksheets
        If sht.Visible And (Not sht.Name = FrontPage.Name) Then
            Set DestWB = Workbooks.Add ' Creates a new workbook with only 1 sheet
            sht.Copy After:=DestWB.Sheets(1) 'Copy the sheet in question
            DestWB.Sheets(1).Delete ' Delete the default "Sheet1" which was created in the new workbook
            FrontPage.Copy Before:=DestWB.Sheets(1) ' Now copy the FrontPage
            ' And save & close the destination workbook:
            With DestWB
                .SaveAs FolderName & "\" & sht.Name & FileExtStr, FileFormat:=FileFormatNum, Password:="AreaXXX", WriteResPassword:=""
                .Close False
            End With
        End If
    Next sht
CLEAN_UP:
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .DisplayAlerts = True
        .SheetsInNewWorkbook = SheetsInNewWorkbook
    End With
End Sub

Я не включил сообщение о завершении или преобразование в значения и т. Д .: просто надежный код для копирования листов в новую рабочую книгу, а затем копирования по всему фронтустраница также.