Использовать макрос 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 

Что такое быстрое исправление?

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 

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