4

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

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?

4

2 回答 2

12

将工作表保留在现有工作簿中并创建带有副本的新工作簿

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
于 2013-11-12T21:49:24.093 回答
1

我建议引入一些错误检查，以确保您最终尝试将工作簿保存到的文件夹确实存在。这还将创建相对于您保存启用宏的 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
于 2017-06-14T14:59:57.233 回答