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

Question

你好，我正在尝试使用这段代码将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

快速修复是什么？

- Kairan

---

创建一个新的工作簿并将工作表复制到其中，然后保存新的工作簿。 - Sorceri

实现Sorceri的建议的简单方法是使用worksheet.Move……这将创建新的工作簿，并允许稍后保存和关闭它。 - Gary's Student

move 的唯一问题是它的返回值是 void，所以你必须找到工作簿来保存它。 - Sorceri

你是正确的！ - Gary's Student

Answer 1

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

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

- Sorceri

---

非常好，谢谢。而且不需要使用ActiveWorkbook。 - Kairan

@Sorceri 是的，我做到了，那是容易的部分。 - Kairan

Answer 2

我建议引入一些错误检查，以确保您最终尝试保存工作簿的文件夹确实存在。这也将相对于您保存的带宏Excel文件创建文件夹。

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

我强烈建议在保存新创建的工作簿后立即关闭它。如果您正在尝试创建大量新的工作簿，您很快就会发现它会拖慢您的系统。

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

- Crayons