使用VBAmacros将每个Excel工作表保存为单独的工作簿

嗨我想要使用此代码将每张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 

什么是快速修复？

Answer 1

将工作表保留在现有的工作簿中，并创build一个带有副本的新工作簿

 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 

Answer 2

我build议引入一些错误检查，以确保您最终将尝试保存工作簿的文件夹实际存在。 这也将创build该文件夹相对于您保存您的macros启用Excel文件的任何地方。

 On Error Resume Next MkDir ThisWorkbook.path & "\Calendars\" On Error GoTo 0 

我也强烈build议保存后立即closures新创build的工作簿。 如果您尝试创build大量新的工作簿，您很快就会发现它滞后于您的系统。

 wb.Close 

而且，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