Excel VBA不断崩溃的问题

Question

我正在构建一个会根据某些选择而改变的工作表。我定义了用于复制和粘贴不同数据的范围，具体取决于应向用户显示的工作表类型。

自从我构建了复制和粘贴机制以来，当我运行代码以将工作表换成不同的外观时，工作表经常崩溃。

我在错误检查中得到“对象'Range'的方法'PasteSpecial'失败”，然后是“运行时错误”-2147417848 (80010108)'：自动化错误调用的对象已与其客户端断开连接。”会发生，有时工作表运行得很好，没有错误，有时它被错误淹没。通常在出现此错误后，我会结束，然后我会得到一个“Microsoft Excel 已停止工作”错误“windows 可以尝试重新启动程序”。它有时会恢复，但通常不会。

我试图在没有任何宏或代码的情况下复制单元格并粘贴它们，但 excel 一直在崩溃。 我正在复制并粘贴一堆格式化的边框和背景颜色以及一些文本也在盒子里。

Public Sub SetupSheetForEquipmentType(equipment As EquipType)
Dim ws As Worksheet
Set ws = Sheets("Input")


Dim info As Worksheet
Set info = Sheets("Info")


Call Unprotect(ws)

ws.Range("selectedEquipType") = equipment

'Normarc Style
'show all rows first
On Error Resume Next
If ws.Rows(14).EntireRow.Hidden = True Then
    ws.Rows(14).EntireRow.Hidden = False
    ws.Rows(16).EntireRow.Hidden = False
    ws.Columns(2).EntireColumn.Hidden = False
End If
On Error GoTo errSec
'setup the sheet
'Application.DisplayAlerts = False
'Application.ScreenUpdating = False
Select Case equipment
Case Is = 2
    ws.Range("title") = "ILS PHL7801 MONITOR READINGS"
Case Is = 3
    ws.Range("title") = "ILS NORMARC 'A' MONITOR READINGS"
Case Is = 4
    ws.Range("title") = "ILS NORMARC 'B' MONITOR READINGS"
End Select

If Not equipment = PHL7801 Then

    ws.Rows(24).RowHeight = 15
    ws.Rows(25).RowHeight = 15
    ws.Columns(3).ColumnWidth = 6

    'make the sheet input look appropriate
    info.Range("NMSheet").Copy
    DoEvents
    DoEvents
    DoEvents
    ws.Range("SheetGuts").PasteSpecial xlPasteAll '************crashes here*********** but works with xlPasteValues

    'put the comment box in
    info.Range("NMComment").Copy
    ws.Range("NMCommentRef").PasteSpecial 
    ThisWorkbook.Names("comment").Delete
    ws.Range("I35").Name = "comment"
End If

Select Case equipment
Case Is = NMA

    info.Range("NMACL").Copy
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    ws.Range("NMCPNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone

    info.Range("NMADS").Copy
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    ws.Range("NMDSNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone

    info.Range("NMARef").Copy
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    ws.Range("NMRefNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone

Case Is = NMB
    info.Range("NMBCL").Copy
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    ws.Range("NMCPNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone

    info.Range("NMBDS").Copy
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    ws.Range("NMDSNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone

    info.Range("NMBRef").Copy
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    ws.Range("NMRefNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone

Case Is = PHL7801

    'make the sheet input look appropriate
    info.Range("PHLSheet").Copy
    DoEvents
    DoEvents
    DoEvents
    ws.Range("SheetGuts").PasteSpecial

    'hide the rows that aren't applicable and size them appropriately
    ws.Columns(2).Hidden = True
    ws.Rows(14).Hidden = True
    ws.Rows(16).Hidden = True
    ws.Rows(24).RowHeight = 30
    ws.Rows(25).RowHeight = 30
    ws.Columns(3).ColumnWidth = 10

    info.Range("PHLCL").Copy
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    ws.Range("NMCPNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone

    info.Range("PHLDS").Copy
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    ws.Range("NMDSNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone

    info.Range("PHLRef").Copy
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    ws.Range("NMRefNames").PasteSpecial xlPasteAllExceptBorders, xlPasteSpecialOperationNone

    'put the comment box in
    info.Range("PHLComment").Copy
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    DoEvents
    ws.Range("NMCommentRef").PasteSpecial xlPasteAll, xlPasteSpecialOperationNone

    ThisWorkbook.Names("comment").Delete
    ws.Range("D35").Name = "comment"
End Select
errSec:
    If Err.Number <> 0 Then

    MsgBox "Error: " & Err.Description
    Err.Clear
End If

Call Protect(ws)
'Application.ScreenUpdating = True
'Application.DisplayAlerts = True
End Sub

编辑： 我也一直在阅读并确定转储临时文件应该会有所帮助，位于此处：C:\Users\username\AppData\Local\Temp。在这和查尔斯的回答之间，它似乎工作正常，除了我的捕获错误说：“要做到这一点，所有合并的单元格需要具有相同的大小”。我想知道我拥有的所有合并单元格是否有问题？

再次编辑：我说得太早了。我注意到使用 xlpastevalues 无法正常复制和粘贴，因此我将其更改为 xlPasteAll，现在它又崩溃了。

Answer 1

您似乎缺少粘贴值

ws.Range("SheetGuts").PasteSpecial xPasteValues

Answer 2

而不是.Copy，然后是.PasteSpecial xlPasteAll（也避免重复的DoEvents，你能看看这是否有效：

ws.Range("NMRefNames").Unmerge
info.Range("NMSheet").Copy Destination:=ws.Range("NMRefNames")

您可能还需要在下一个区块中进行类似操作：

info.Range("NMComment").Copy
ws.Range("NMCommentRef").PasteSpecial 

如果有或可能合并单元格：

info.Range("NMComment").Copy Destination:=ws.Range("NMCommentRef")
ws.Range("NMCommentRef").Value = ws.Range("NMCommentRef").Value  'Gets rid of formula/etc

另外，对于您的 PasteAllExceptBorders 块，请尝试对所有这些块执行此操作：

info.Range("NMBDS").Copy Destination:=ws.Range("NMDSNames")
ws.Range("NMDSNames").Borders.LineStyle = xlNone