Copy multiple sheets to one workbook

Question

I found this code in extendoffice website. However it doesn't meet what I need to do with the sheets. I have also search here unfortunately, it doesn't also meet my requirements.

The code below works great but it saves each worksheet as individual workbook. Basically I have 4 sheets in my main workbook. And the result is, it saves each sheet as one workbook. I wanted it to be the same (Saving in a folder) but worksheets should be saved in one workbook.

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

Sevpoint Sevpoint · Accepted Answer · 2017-02-14T06:19:38

I was able to get what I need with the code below:

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

Copy multiple sheets to one workbook

1 Answers