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

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

1 个答案: