Excel 将工作表从一个WB移动到另一个新WB

我编写了以下代码，用于将工作表从一个WB移动到另一个新WB

但是，我遇到了错误

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

Sub-MoveSheets01（）
将ws设置为工作表
将新WB设置为工作簿
将旧WB作为工作簿
Application.ScreenUpdating=False
设置oldwb=ActiveWorkbook
设置newWB=Application.Workbooks.Add
激活旧wb
对于旧工作表中的每个ws
如果ws.Name“输入”和ws.Name“输出”，那么
Application.DisplayAlerts=False
ws.Copy after:=newWB.Sheets（newWB.Sheets.Count）
ws.Delete
Application.DisplayAlerts=True
如果结束
下一个ws
旧wb.Save
newWB.Activate
Application.DisplayAlerts=False
工作表（“工作表1”）。删除
Application.DisplayAlerts=True
newWB.SaveAs文件名：=oldwb.Path&“\AAA”和Format（Now（），“DD.MMM.yyy hh.mm AMPM”）和“.xlsx”，CreateBackup:=False
端接头

它生成一个新的WB

---

但在我保存它们的那一刻，文件就崩溃了。

试试这个。请参阅注释，特别是关于文件名的注释。很可能您的文件名太长。如果发生错误-发布带有错误文本的注释

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

Sub-MoveSheets010（）
将ws设置为工作表
将新WB设置为工作簿
将旧WB作为工作簿
变光链路
'为整个潜艇关闭此开关
应用
.DisplayAlerts=False
.ScreenUpdate=False
以
设置oldwb=thiswoolk
对于旧工作表中的每个ws
如果ws.Name“输入”和ws.Name“列表”_
和ws.Name“Temp”和ws.Name“Index Data”_
ws.Name“比率”和ws.Name“总回报指数”_
然后ws.Name“India VIX”和ws.Name“Output”
'检查是否分配了新WB
如果不是，那么newWB什么都不是
'如果指定-只需在此处添加工作表
ws.Move before:=newWB.Sheets（1）
其他的
'如果未指定-通过移动工作表创建新工作簿
'这将创建只有一张工作表的新工作簿
因此将不会有“Sheet1”、“Sheet2”等
ws.Move
'分配新WB
设置newWB=ActiveWorkbook
如果结束
如果结束
下一个
设置ws=Nothing
'首先保存新wb以避免有关链接/引用的消息
newWB.SaveAs文件名：=oldwb.Path&“\AAA”和Format（Now（），“DD.MMM.yyy hh.mm AMPM”）和“.xlsx”，CreateBackup:=False
'从源wb中删除引用并保存它
与oldwb
如果不是空的（.LinkSources（xlExcelLinks）），则
对于.LinkSources（xlExcelLinks）中的每个链接
.BreakLink链接，XLLinkTypeExcelLink
下一环节
如果结束
拯救
以
“把这个打开
应用
.DisplayAlerts=True
.ScreenUpdate=True
以
端接头

文件仍处于静止状态，新WB和旧WB之间存在一些链接。该文件在共享，但仍链接我端的两个WB。仍不工作。在下面共享输出文件以生成工作表，运行索引（）。我知道当文件移动时，输出文件有一些命名范围，即链接。现在我无法断开该链接现在它工作正常，我已删除了命名范围。现在可以找到了。谢谢@Vitaliy Prushak