将多个工作表复制到一个工作簿

Question

我在extendoffice网站中找到了此代码。然而它不符合我需要做的工作表。我不幸在这里搜索，它不符合我的要求。

下面的代码很好用，但它将每个工作表保存为单独的工作簿。基本上我在我的主要工作簿中有4张。结果是，它将每张表保存为一个工作簿。我希望它是相同的（保存在一个文件夹中），但工作表应该保存在一个工作簿中。

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

我能得到什么，我需要用下面的代码：

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