Перемещение листа из одного ББ в другой Новый ББ

Question

Я сделал следующий код для перемещения листа из одного ББ в другой Новый ББ.

Однако возникают ошибки.

Sub MoveSheets01()
   Dim ws As Worksheet
   Dim newWB As Workbook
   Dim oldwb As Workbook

   Application.ScreenUpdating = False
   Set oldwb = ActiveWorkbook
   Set newWB = Application.Workbooks.Add

   oldwb.Activate

   For Each ws In oldwb.Sheets
      If ws.Name <> "Input" And ws.Name <> "Output" Then
         Application.DisplayAlerts = False
         ws.Copy after:=newWB.Sheets(newWB.Sheets.Count)
         ws.Delete
         Application.DisplayAlerts = True
      End If
   Next ws

   oldwb.Save
   newWB.Activate
   Application.DisplayAlerts = False
   Sheets("Sheet1").Delete
   Application.DisplayAlerts = True
   newWB.SaveAs Filename:=oldwb.Path & "\AAA " & Format(Now(), "DD.MMM.YYYY hh.mm AMPM") & ".xlsx", CreateBackup:=False
End Sub

Создается новый ББ.

Но в момент сохранения файла происходит сбой.

Answer 1

Попробуй это. Смотрите комментарии, особенно в отношении имени файла. Скорее всего, у вас слишком длинное имя файла. Если произошла ошибка - оставьте комментарий с текстом ошибки.

Sub MoveSheets010()
Dim ws As Worksheet
Dim newWB As Workbook
Dim oldwb As Workbook
Dim link As Variant

' switch this off for the whole sub
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With

Set oldwb = ThisWorkbook

For Each ws In oldwb.Sheets
    If ws.Name <> "Input" And ws.Name <> "List" _
        And ws.Name <> "Temp" And ws.Name <> "Index Data" _
        And ws.Name <> "Ratio's" And ws.Name <> "Total Returns Index" _
        And ws.Name <> "India VIX" And ws.Name <> "Output" Then
    '   check whether newWB is assigned
        If Not newWB Is Nothing Then
            ' if assigned - just add sheet there
            ws.Move before:=newWB.Sheets(1)
        Else
            ' if not assign - create new workbook by moving the sheet
            ' this creates new workbook with only one sheet
            ' so there will be no "Sheet1", "Sheet2", etc
            ws.Move
            ' assign newWB
            Set newWB = ActiveWorkbook
        End If
    End If
Next

Set ws = Nothing

' save new wb first to avoid message about links/references
newWB.SaveAs Filename:=oldwb.Path & "\AAA " & Format(Now(), "DD.MMM.YYYY hh.mm AMPM") & ".xlsx", CreateBackup:=False

' remove references from source wb and save it
With oldwb
If Not IsEmpty(.LinkSources(xlExcelLinks)) Then
    For Each link In .LinkSources(xlExcelLinks)
        .BreakLink link, xlLinkTypeExcelLinks
    Next link
End If
    .Save
End With

' switch this on back
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
End With

End Sub