使用一定数量的工作表进行宏保存后，工作簿会损坏并无法打开

Question

在一个excel实例（实例A）中，我的工作簿（工作簿A）根据用户输入执行计算，并创建带有图表对象的工作表。此工作表被复制并粘贴到另一个工作簿（工作簿B）中，该工作簿在实例A中关闭，然后在第二个Excel实例（实例B）中打开。工作簿B /实例B保持打开并在单独的窗口中，因为工作簿A /实例A的功能是创建要在工作簿B /实例B中查看的工作表。

所以宏过程是：在实例A /工作簿A中创建工作表 - ＆gt;工作簿B在实例B中关闭 - ＆gt;工作簿B在实例A中打开 - ＆gt;工作表从工作簿A复制到工作簿B - ＆gt;工作簿B在实例A中保存/关闭 - ＆gt;工作簿B在实例B中打开

为了完全披露，这是整个子：

Sub CopySSToNewWorkbook()


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Dim MoveFromWkb As Workbook
Dim MoveFromSht As Worksheet
Dim ChartName As String
Dim RngToCover As Range
Dim duplicateChtPic As Shape
Dim NewSheetName As String

Dim TagString As String
If InputPage.Range("PanelTag") <> "" Then TagString = "-" & InputPage.Range("PanelTag").Text

Set MoveFromWkb = ThisWorkbook
'Set MoveFromSht = MoveFromWkb.Sheets("InputPage")
If InputPage.Range("PgNum") <> "" Then
    NewSheetName = InputPage.Range("RoomNum").Text & TagString & " (Pg" & InputPage.Range("PgNum") & ")"
    Set MoveFromSht = MoveFromWkb.Worksheets(NewSheetName)
Else
    NewSheetName = InputPage.Range("RoomNum").Text & TagString
    Set MoveFromSht = MoveFromWkb.Worksheets(NewSheetName)
End If

Set RngToCover = MoveFromSht.Range("E19:Y34")

ChartName = "Panel" & InputPage.Range("PgNum")

'Duplicate method
Set duplicateChtPic = MoveFromSht.ChartObjects(ChartName).Duplicate()
MoveFromSht.Shapes(ChartName).Delete
duplicateChtPic.ZOrder msoSendToBack
duplicateChtPic.Select
Call DelinkChartFromData


With duplicateChtPic
    .height = RngToCover.height ' resize
    .Width = RngToCover.Width   ' resize
    .top = RngToCover.top - 2     ' reposition
    .Left = RngToCover.Left - 6 ' reposition

End With

MoveFromSht.Shapes("SaveSpoolSheetButton").Delete
MoveFromSht.Shapes("EditSpoolSheetButton").Visible = msoTrue
MoveFromSht.Shapes("UpdatePageNumberButton").Visible = msoTrue
MoveFromSht.Shapes("DeletePanelButton").Visible = msoTrue


Dim CNumber As String
Dim RelNum As String
Dim CrtNum As String
Dim Percentage As String
Dim SSFolderName As String
Dim Wkbname As String
Dim FileLocation As String
Dim Sht As Worksheet
Dim SSCopyYesNo As Integer
Dim DoubleSheet As Boolean
Dim MoveToWkb As Workbook
Dim MoveToSht As Worksheet
Dim PasteSheet As Worksheet
Dim CellName As name
Dim SheetCounter As Integer

SheetCounter = 1

Dim i As Integer
Dim varLinks As Variant

With InputPage
    CNumber = .Range("JNumber").Text
    CrtNum = "Crt" & .Range("CrateNum").Text
    RelNum = "Rel" & .Range("RelNum").Text
    Percentage = (.Range("RelPct").value * 100) & "Pct"
End With

If CNumber <> "" Then
    Wkbname = Wkbname & CNumber
End If

If RelNum <> "Rel" Then
    Wkbname = Wkbname & "_" & RelNum
End If

If CrtNum <> "Crt" Then
    Wkbname = Wkbname & "_" & CrtNum
End If

If Percentage <> "0Pct" Then
    Wkbname = Wkbname & "_" & Percentage
End If

SSFolderName = CreateSSFolders
FileLocation = SSFolderName & "\" & Wkbname & ".xlsb"


Dim newXL As Excel.Application


'Set newXL = GetObject(FileLocation).Application
If IsFileOpen(FileLocation) = True Then
    Set newXL = GetObject(FileLocation).Application

    newXL.Application.ScreenUpdating = False
    newXL.DisplayAlerts = False
    newXL.Application.Workbooks(Wkbname & ".xlsb").Close SaveChanges:=False
'    newXL.Application.Quit



'    Set newXL = Nothing
Else
    Set newXL = CreateObject("Excel.Application")
    newXL.Visible = True
End If


If FileFolderExists(FileLocation) Then
'    newXL.Application.ScreenUpdating = False
'    newXL.Application.DisplayAlerts = False

'    On Error Resume Next
'    newXL.Workbooks(Wkbname & ".xlsb").Close SaveChanges:=False
'    On Error GoTo 0

    Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False

    Set MoveToWkb = Workbooks(Wkbname & ".xlsb")
Else
    Workbooks.Open (InputPage.MainFolderLocation.Text & "calc_and_trans\SpoolSheetWorkbookTemplate.xlsb")
    Set MoveToWkb = Workbooks("SpoolSheetWorkbookTemplate.xlsb")

    'if SSFolder doesn't already exist, the EditSpoolSheet module is imported to the new spoolsheet
    'it is also exported to update any changes made
    If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
        MoveFromWkb.VBProject.VBComponents("EditSpoolSheet").export InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas" 'change path for home
        MoveToWkb.VBProject.VBComponents.Import InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas" 'change path for home

    Else
        MoveFromSht.Shapes("EditSpoolSheetButton").Visible = msoFalse
        MoveFromSht.Shapes("UpdatePageNumberButton").Visible = msoFalse
        MoveFromSht.Shapes("CancelEditButton").Visible = msoFalse
        MoveFromSht.Shapes("DeletePanelButton").Visible = msoFalse
    End If
End If

For Each CellName In MoveToWkb.Names
    If Right(CellName.name, 10) <> "Print_Area" Then
        CellName.Delete
    End If
Next

Dim NewPgNum As String
Dim OldPgNum As String
Dim startRead As Integer
Dim continueRun As Boolean
continueRun = False


NewPgNum = InputPage.Range("PgNum")
For Each Sht In MoveToWkb.Worksheets
    startRead = InStr(Sht.name, "(Pg")

    If Mid(Sht.name, startRead + 3) = (Right(MoveFromSht.name, Len(NewPgNum) + 1)) And DoubleSheet = False Then
        DoubleSheet = True
        Application.ScreenUpdating = True
        SSCopyYesNo = MsgBox("Do you want to overwrite " & Sht.name & "?", vbYesNo + vbQuestion)
        Application.ScreenUpdating = False

        If SSCopyYesNo = vbYes Then
            Dim spoolPosition As Integer
            spoolPosition = Sht.Index
            Sht.name = "_"
            'attaching a macro to the edit spool sheet button
            If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
                MoveFromSht.Shapes("EditSpoolSheetButton").OnAction = "EditSpoolSheetClicked"
                MoveFromSht.Shapes("UpdatePageNumberButton").OnAction = "UpdatePageNumberClicked"
                MoveFromSht.Shapes("CancelEditButton").OnAction = "CancelEditButtonClicked"
                MoveFromSht.Shapes("DeletePanelButton").OnAction = "DeletePanelButtonClicked"
            End If
            MoveFromSht.Range("Page_Number") = MoveFromSht.Range("AK21")
            MoveFromSht.Copy After:=MoveToWkb.Sheets(spoolPosition)
            Application.DisplayAlerts = False
            Sht.Delete
            Application.CutCopyMode = False
            continueRun = True
        End If

    ElseIf DoubleSheet <> True Then
        DoubleSheet = False
    End If
    SheetCounter = SheetCounter + 1
Next



If DoubleSheet = False Then
    Set PasteSheet = Workbooks(MoveToWkb.name).Worksheets.Add
'    MoveFromSht.Copy before:=MoveToWkb.Sheets(1)
    'attaching a macro to the edit spool sheet button
    If FileFolderExists(InputPage.MainFolderLocation.Text & "calc_and_trans\ExportModules\EditSpoolSheet.bas") Then 'change path for home
        MoveFromSht.Shapes("EditSpoolSheetButton").OnAction = "EditSpoolSheetClicked"
        MoveFromSht.Shapes("UpdatePageNumberButton").OnAction = "UpdatePageNumberClicked"
        MoveFromSht.Shapes("CancelEditButton").OnAction = "CancelEditButtonClicked"
        MoveFromSht.Shapes("DeletePanelButton").OnAction = "DeletePanelButtonClicked"
    End If
    MoveFromSht.Range("Page_Number") = MoveFromSht.Range("AK21")
    MoveFromSht.Copy After:=MoveToWkb.Sheets(SheetCounter)
    Application.CutCopyMode = False
    continueRun = True
End If

If continueRun Then

    For Each Sht In MoveToWkb.Worksheets
        If Mid(Sht.name, 1, 5) = "Sheet" Then
            Application.DisplayAlerts = False
            Sht.Delete
        End If
    Next


    Set MoveToSht = MoveToWkb.Sheets(MoveFromSht.name)

    Dim moveToShtName As String
    moveToShtName = MoveToSht.name

    'fix in here
    For Each CellName In MoveToWkb.Names
        If Right(CellName.name, 10) <> "Print_Area" Then
            Application.DisplayAlerts = False
            CellName.Delete
        End If
    Next

    Application.PrintCommunication = False
    MoveToSht.DisplayPageBreaks = False

    'For Each Sht In MoveToWkb.Worksheets
        With MoveToSht.PageSetup

                .PrintArea = "$A$1:$Z$36"
                .Orientation = xlLandscape
                .PaperSize = xlPaperLetter
                .BlackAndWhite = True
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
                .LeftMargin = Application.InchesToPoints(1.6)
                .RightMargin = Application.InchesToPoints(0)
                .TopMargin = Application.InchesToPoints(0)
                .BottomMargin = Application.InchesToPoints(0)
                .HeaderMargin = Application.InchesToPoints(0)
                .FooterMargin = Application.InchesToPoints(0)
                .CenterHorizontally = True
                .CenterVertically = True

        End With

    Application.PrintCommunication = True



    '%%%%%%%%new crate code %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


    '******************* Update Crate Sheet Info **************************************'
    Dim crateSht As Worksheet
    Dim frontSht As Worksheet
    Set crateSht = MoveToWkb.Sheets("Crate_List")
    Set frontSht = MoveToWkb.Sheets("FrontSheet")

    Dim writeRow As Integer
    Dim continueToEnd As Boolean
    Dim roomColumn As Integer, pageColumn As Integer, sizeColumn As Integer, widthColumn As Integer, typeColumn As Integer, tagColumn As Integer
    Dim infoTableCol As Integer

    Dim colStep As Integer
    For colStep = 1 To 15
        Select Case crateSht.Cells(1, colStep).Text
            Case "ROOM #"
                roomColumn = colStep
            Case "PAGE #"
                pageColumn = colStep
            Case "PANEL SIZE"
                sizeColumn = colStep
            Case "PANEL WIDTH"
                widthColumn = colStep
            Case "SQFT"
                infoTableCol = colStep
            Case "PANEL TYPE"
                typeColumn = colStep
            Case "PANEL TAG"
                tagColumn = colStep
        End Select
    Next



    'if first spoolsheet being added, set constant values (job name, job number etc.)
    If MoveToWkb.Sheets.count = 3 Then
        frontSht.Cells(5, 6) = MoveToSht.Range("AK2")
        frontSht.Cells(6, 6) = MoveToSht.Range("AK3")
        Dim EventsState As Boolean
        EventsState = Application.EnableEvents
        Application.EnableEvents = False
        frontSht.Cells(6, 12) = MoveToSht.Range("AK7")
        Application.EnableEvents = EventsState
    End If

    'determines where to write panel data: if row is blank, if Page # being written and read are both "" and panel tag/room # match, and if page numbers are not "" and match
    For writeRow = 2 To 500
        If Len(crateSht.Range("A" & writeRow).value) = 0 Or (InputPage.Range("PgNum") = "" And crateSht.Cells(writeRow, pageColumn).value = "" And crateSht.Range("A" & writeRow).value = InputPage.Range("RoomNum").value And _
        crateSht.Cells(writeRow, tagColumn).value = InputPage.Range("PanelTag").value) Or (InputPage.Range("PgNum").value <> "" And _
        InputPage.Range("PgNum").value = crateSht.Cells(writeRow, pageColumn).value) Then
            'If continueToEnd Then
            Exit For
        End If
    Next

    Dim panelCrateData(24) As Variant
    Dim panelTableData As Variant
    panelTableData = MoveToSht.Range("AK1:AK39")

    'writing spoolsheet information to crate sheet
    With MoveToSht
        If roomColumn <> 0 Then crateSht.Cells(writeRow, roomColumn) = panelTableData(22, 1) '.Range("AK22")
        If pageColumn <> 0 Then crateSht.Cells(writeRow, pageColumn) = panelTableData(21, 1) '.Range("AK21")
        If sizeColumn <> 0 Then crateSht.Cells(writeRow, sizeColumn) = panelTableData(13, 1) '.Range("AK13")
        If widthColumn <> 0 Then crateSht.Cells(writeRow, widthColumn) = panelTableData(12, 1) ' .Range("AK12")
        If tagColumn <> 0 Then crateSht.Cells(writeRow, tagColumn) = panelTableData(24, 1)
        If typeColumn <> 0 Then crateSht.Cells(writeRow, typeColumn) = panelTableData(23, 1)

        panelCrateData(0) = Round(CDbl(Replace(.Range("X35").Text, "SQFT", "")), 2)
        panelCrateData(1) = panelTableData(15, 1) '.Range("AK15")
        panelCrateData(2) = panelTableData(14, 1) '.Range("AK14")
        panelCrateData(3) = panelTableData(17, 1) '.Range("AK17")
        panelCrateData(4) = panelTableData(16, 1) '.Range("AK16")
        panelCrateData(5) = panelTableData(18, 1) '.Range("AK18")
        panelCrateData(6) = panelTableData(20, 1) '.Range("AK20")
        panelCrateData(7) = panelTableData(19, 1) '.Range("AK19")
        panelCrateData(8) = panelTableData(25, 1) '.Range("AK23")
        panelCrateData(9) = panelTableData(26, 1) '.Range("AK24")
        panelCrateData(10) = panelTableData(27, 1) '.Range("AK25")
        panelCrateData(11) = panelTableData(29, 1) '.Range("AK27")
        panelCrateData(12) = panelTableData(30, 1) '.Range("AK28")
        panelCrateData(13) = panelTableData(31, 1) '.Range("AK29")
        panelCrateData(14) = panelTableData(28, 1) '.Range("AK26")
        panelCrateData(15) = panelTableData(34, 1) '.Range("AK32")
        panelCrateData(16) = panelTableData(33, 1) '.Range("AK31")
        panelCrateData(17) = panelTableData(35, 1) '.Range("AK33")
        panelCrateData(18) = panelTableData(36, 1) '.Range("AK34")
        panelCrateData(19) = panelTableData(37, 1) '.Range("AK35")
        panelCrateData(20) = panelTableData(38, 1) '.Range("AK36")
        panelCrateData(21) = panelTableData(39, 1) '.Range("AK37")
        panelCrateData(22) = .Range("AU19")

        'Holdback Info
        panelCrateData(23) = .Range("AU12")
        panelCrateData(24) = .Range("AU14")

        'Additional Saddles
        crateSht.Range(crateSht.Cells(writeRow, infoTableCol), crateSht.Cells(writeRow, infoTableCol + 24)) = panelCrateData ' "M" & writeRow & ":AK" & writeRow) = panelCrateData

    End With


    For writeRow = 2 To 500
        If Len(crateSht.Range("A" & writeRow).value) = 0 Then ' Or crateSht.Range("A" & writeRow).value = InputPage.Range("RoomNum").value Then
            'If continueToEnd Then
            Exit For
        End If
    Next


    Dim lastRow As Integer
    lastRow = writeRow - 1

    Dim totSqft As Double
    totSqft = WorksheetFunction.Sum(crateSht.Range(crateSht.Cells(2, infoTableCol), crateSht.Cells(lastRow, infoTableCol))) '(crateSht 2:M" & lastRow))


    Application.PrintCommunication = False
    With crateSht
        .PageSetup.PrintArea = "$A$1:$H$" & CStr(lastRow)
        .PageSetup.PrintTitleRows = "$1:$1"
        If lastRow = 2 Then .PageSetup.CenterHeader = "#" & MoveToSht.Range("AK3").value

        .PageSetup.RightFooter = CStr(lastRow - 1) & " PANELS" & vbLf & "TOUCH UP KIT" & vbLf & "INTERCONNECTORS" _
                                 & vbLf & "GLOVES" & vbLf & "T-BAR CLIPS" & vbLf & "INSULATION ON PANEL"

        .PageSetup.RightHeader = CStr(totSqft) & " SQFT"




    End With
    Application.PrintCommunication = True

    With frontSht
        .Cells(11, 2) = lastRow - 1
        .Cells(30, 2) = totSqft
    End With


    MoveToWkb.SaveAs filename:=FileLocation, FileFormat:=50

    MoveToWkb.Close False

    Set MoveToWkb = Nothing

    '**********************************************************************************'

    'Add new entry to recent panels table, unless room number already exists then replace that entry with the current info=
    Call AddRecentPanelData

    MoveFromSht.Delete

    newXL.Application.ScreenUpdating = True
    newXL.Application.DisplayAlerts = True
    newXL.Application.AskToUpdateLinks = True
    Application.Calculation = xlCalculationAutomatic

    Set MoveFromWkb = Nothing
    Set MoveFromSht = Nothing
    Set MoveToSht = Nothing


    newXL.Workbooks.Open FileLocation ', UpdateLinks:=False ', ReadOnly:=False

    Set newXL = Nothing



Else
    MoveToWkb.Close SaveChanges:=False

    Set MoveToWkb = Nothing

    newXL.Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False

    MoveFromSht.Delete

    Application.Calculation = xlCalculationAutomatic

    Set newXL = Nothing
    Set MoveFromWkb = Nothing
    Set MoveFromSht = Nothing
    Set MoveToSht = Nothing

End If

Exit Sub

'#########################################################################################
ErrorHandler:

    Dim Msg As String
    If Err.number <> 0 Or Err.number <> 20 Then
     Msg = "Error # " & Str(Err.number) & " was generated by " _
             & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
     MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
    End If

    Call ReactiveUpdating

End Sub

因此，工作簿A使用此子工作创建工作簿B /实例B并将工作表保存到其中。问题是，当工作簿A尝试添加第20个工作表（有时是第24或第23个但在此区域中一致）时，在此行上打开实例B中的工作簿B时出错（从底部向上滚动一对）导致代码打破：

newXL.Workbooks.Open FileLocation, UpdateLinks:=False, ReadOnly:=False

Method 'Open' of object 'Workbooks' failed

如果在弹出此错误后单击“继续”，则会在没有问题的情况下完成，但实例B中的工作簿B已损坏。此外，如果我单击X关闭它Excel崩溃，并且工作簿B已损坏/无法打开。

奇怪的是，在保存相同数量的工作表（20-23个工作表之间）后，它总会崩溃。即使我在保存19次之后（在预期崩溃之前）尝试完全关闭工作簿和实例，保存第20个工作表仍然会导致崩溃。

这仅在大约一个月前开始发生，它发生在我们测试过的所有计算机上。我们甚至测试了工作簿的旧版本，当然从未遇到过这个问题，并且它们都有相同的问题。

如果您能提供任何帮助或需要更多细节，请告知我们，非常感谢任何见解！

Answer 1

经过大量工作试图改变工作簿的保存/打开过程后，我设法找出了问题。正在保存的工作簿（工作簿B）包含一个ActiveX列表框控件对象，在删除它之后问题就消失了。希望这能节省一些人解决它的时间！