使用 VBA 宏将每个 Excel 工作表保存为单独的工作簿
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/19940409/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Use VBA Macro to Save each Excel Worksheet as Separate Workbook
提问by Kairan
Hi I am trying to use this code to save each sheet of Excel to a new workbook. However, it is saving the entire workbook to the new filename
嗨，我正在尝试使用此代码将每张 Excel 工作表保存到新工作簿中。但是，它将整个工作簿保存为新文件名
Dim path As String
Dim dt As String
dt = Now()
path = CreateObject("WScript.Shell").specialfolders("Desktop") & "\Calendars " & Replace(Replace(dt, ":", "."), "/", ".")
MkDir path
Call Shell("explorer.exe" & " " & path, vbNormalFocus)
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'SetVersions
If ws.name <> "How-To" And ws.name <> "Actg_Prd" Then
ws.SaveAs path & ws.name, xlsx
End If
Next ws
What is the quick fix?
什么是快速修复？
回答by Sorceri
Keeping the worksheet in the existing workbook and creating a new workbook with a copy
将工作表保留在现有工作簿中并创建带有副本的新工作簿
Dim path As String
Dim dt As String
dt = Now()
path = CreateObject("WScript.Shell").specialfolders("Desktop") & "\Calendars " & Replace(Replace(dt, ":", "."), "/", ".")
MkDir path
Call Shell("explorer.exe" & " " & path, vbNormalFocus)
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'SetVersions
If ws.Name <> "How-To" And ws.Name <> "Actg_Prd" Then
Dim wb As Workbook
Set wb = ws.Application.Workbooks.Add
ws.Copy Before:=wb.Sheets(1)
wb.SaveAs path & ws.Name, Excel.XlFileFormat.xlOpenXMLWorkbook
Set wb = Nothing
End If
Next ws
回答by Crayons
I recommend introducing some error checking so as to ensure the folder you'll ultimately try to save workbooks to, actually exists. This will also create the folder relative to wherever you've saved your macro-enabled excel file.
我建议引入一些错误检查，以确保您最终尝试将工作簿保存到的文件夹确实存在。这还将创建相对于您保存启用宏的 Excel 文件的位置的文件夹。
On Error Resume Next
MkDir ThisWorkbook.path & "\Calendars\"
On Error GoTo 0
I also highly recommend closing the newly created workbook as soon as it's saved. If you are trying to create a large number of new workbooks, you'll quickly find how much it lags your system.
我还强烈建议在保存后立即关闭新创建的工作簿。如果您尝试创建大量新工作簿，您会很快发现它滞后于您的系统的程度。
wb.Close
Moreover, Sorceri's code will not save an excel file with the appropriate file extension. You must specify that in the file name.
此外，Sorceri 的代码不会保存具有适当文件扩展名的 excel 文件。您必须在文件名中指定。
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets 'SetVersions
If ws.Name <> "How-To" And ws.Name <> "Actg_Prd" Then
Dim wb As Workbook
Set wb = ws.Application.Workbooks.Add
ws.Copy Before:=wb.Sheets(1)
wb.SaveAs path & ws.Name & ".xlsx", Excel.XlFileFormat.xlOpenXMLWorkbook
wb.Close
Set wb = Nothing
End If
Next ws
