Mehrere Blätter in eine Arbeitsmappe kopieren

Question

Ich habe diesen Code in der Website von extendoffice gefunden. Jedoch erfüllt es nicht, was ich mit den Blättern machen muss. Ich habe hier leider auch gesucht, es entspricht auch nicht meinen Anforderungen.

Der folgende Code funktioniert gut, aber es spart jedes Arbeitsblatt als einzelne Arbeitsmappe. Grundsätzlich habe ich 4 Blätter in meinem Hauptarbeitsbuch. Das Ergebnis ist, dass jedes Blatt als eine Arbeitsmappe gespeichert wird. Ich wollte, dass es dasselbe ist (Speichern in einem Ordner), aber Arbeitsblätter sollten in einer Arbeitsmappe gespeichert werden.

Sub SplitWorkbook() 

Dim FileExtStr As String 
Dim FileFormatNum As Long 
Dim xWs As Worksheet 
Dim xWb As Workbook 
Dim FolderName As String 
Application.ScreenUpdating = False 
Set xWb = Application.ThisWorkbook 
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss") 
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString 
MkDir FolderName 
For Each xWs In xWb.Worksheets 
xWs.Copy 
If Val(Application.Version) < 12 Then 
    FileExtStr = ".xls": FileFormatNum = -4143 
Else 
    Select Case xWb.FileFormat 
     Case 51: 
      FileExtStr = ".xlsx": FileFormatNum = 51 
     Case 52: 
      If Application.ActiveWorkbook.HasVBProject Then 
       FileExtStr = ".xlsm": FileFormatNum = 52 
      Else 
       FileExtStr = ".xlsx": FileFormatNum = 51 
      End If 
     Case 56: 
      FileExtStr = ".xls": FileFormatNum = 56 
     Case Else: 
      FileExtStr = ".xlsb": FileFormatNum = 50 
    End Select 
End If 
xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr 
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum 
Application.ActiveWorkbook.Close False 
Next 
MsgBox "You can find the files in " & FolderName 
Application.ScreenUpdating = True 
End Sub 

Answer 1

Ich war in der Lage zu bekommen, was ich mit dem Code benötigen unter:

Sub ExportSheets() 

Dim wb As Workbook, InitFileName As String, fileSaveName As String 

InitFileName = ThisWorkbook.Path & "\Reminder " & Format(Date, "yyyymmdd") 


    Sheets(Array("SheetName1", "SheetName2", "SheetName3", "SheetName4")).Copy 

Set wb = ActiveWorkbook 

fileSaveName = Application.GetSaveAsFilename(InitialFileName:=InitFileName, _ 
filefilter:="Excel files , *.xlsx") 

With wb 
    If fileSaveName <> "False" Then 

     .SaveAs fileSaveName 
     .Close 
    Else 
     .Close False 
     Exit Sub 
    End If 
End With 

End Sub