没有错误消息的 VBA 应用程序崩溃 - 单步执行程序时有效答案

【问题标题】：VBA App Crashes w/o Error Message - Works when stepping through program没有错误消息的 VBA 应用程序崩溃 - 单步执行程序时有效
【发布时间】：2018-05-15 20:49:38
【问题描述】：

我有一个 excel 应用程序在正常运行时经常崩溃，但并不总是崩溃。如果您设置断点并单步执行程序，它永远不会失败。同样，如果您在战略位置设置断点，然后继续执行它通常也可以正常工作。

此问题似乎与打开文件、复制大量数据然后关闭文件有关。但是，我不确定程序实际上在哪里崩溃。非常感谢调试提示/查找代码中错误发生位置的方法。

我假设这是由于竞争条件或内存问题造成的，但不确定究竟是什么导致了这些错误。不过，竞争条件似乎更有可能，因为暂停或单步执行应用程序不应该有助于解决内存问题。如果竞争条件是问题的原因，是否有比让应用程序在某些点休眠/等待更好的解决方案？如何确定需要休眠/等待的点？

编辑：正常运行应用程序时，它似乎运行的时间比您预期的要长，然后关闭而没有任何错误消息。我在 Win 10 上运行 Excel 2013（32 位）。

我认为将数据保存到剪贴板是问题，并添加了

Application.CutCopyMode = False

每次粘贴后，但这并没有解决问题。

我正在抑制警报和屏幕更新，即

Application.DisplayAlerts = False
Application.ScreenUpdating = False

但注释掉这些设置，仍然会导致应用程序崩溃。

EDIT2：添加发生崩溃的代码。 ReadInAndCopyFiles 中似乎发生了错误。

Sub ReadInFiles(wb As Workbook, FolderPath As String, FileName As String)
Dim CurrentWeekDate As Date
Dim TempDate As Date
Dim TempFilePath As String
Dim DataFileName As String
Dim OpenDialog As Office.FileDialog
Dim DateString As String
Dim SheetNameArray As Variant


'Initialization
CurrentWeekDate = wb.Worksheets("Config").Range("EndOfWeekDate").Value
ChDir (FolderPath)

If FileName = "Weekly utilization" Then
    SheetNameArray = Array("WeeklyUtilization_CW", "WeeklyUtilization_CW-1", "WeeklyUtilization_CW-2", "WeeklyUtilization_CW-3")
Else
    SheetNameArray = Array("Charged Hours", "ChargedHours_CW-1", "ChargedHours_CW-2", "ChargedHours_CW-3")
End If

'Current Week
TempFilePath = FolderPath + FileName + ".xlsx"
ReadInAndCopyFile TempFilePath, CStr(SheetNameArray(0)), "Find " & FileName

'Current Week -1
TempDate = DateAdd("d", -7, CurrentWeekDate)
DateString = Format(TempDate, "yy-mm-dd")
TempFilePath = FolderPath + "Archives\" + FileName + " " + DateString + ".xlsx"
ReadInAndCopyFile TempFilePath, CStr(SheetNameArray(1)), "Find " & FileName & " -1"

'Current Week -2
TempDate = DateAdd("d", -14, CurrentWeekDate)
DateString = Format(TempDate, "yy-mm-dd")
TempFilePath = FolderPath + "Archives\" + FileName + " " + DateString + ".xlsx"
ReadInAndCopyFile TempFilePath, CStr(SheetNameArray(2)), "Find " & FileName & " -2"

'Current Week -3
TempDate = DateAdd("d", -21, CurrentWeekDate)
DateString = Format(TempDate, "yy-mm-dd")
TempFilePath = FolderPath + "Archives\" + FileName + " " + DateString + ".xlsx"
ReadInAndCopyFile TempFilePath, CStr(SheetNameArray(3)), "Find " & FileName & " -3"

End Sub

Sub ReadInAndCopyFile(TempFilePath As String, TargetSheetName As String, CustomMessage As String)
Dim DataFileName As String
Dim SourceWb, wb As Workbook
Dim ws As Worksheet
Dim LastRow, LastColumn, StartRow, TargetLastRow As Variant
Dim OpenDialog As Office.FileDialog

Set wb = ActiveWorkbook

DataFileName = Dir(TempFilePath)
If Not DataFileName <> "" Then
    MsgBox CustomMessage
    Set OpenDialog = Application.FileDialog(msoFileDialogFilePicker)
    OpenDialog.Filters.Clear
    OpenDialog.Filters.Add "Excel Files", "*.xlsx"
    OpenDialog.AllowMultiSelect = False
    OpenDialog.Show
    TempFilePath = OpenDialog.SelectedItems(1)
End If

Workbooks.Open FileName:=TempFilePath, UpdateLinks:=False
Set SourceWb = ActiveWorkbook

'Determine where to start pasting, and if header should be included or not
If (wb.Worksheets(TargetSheetName).Cells(Rows.Count, 1).End(xlUp).Row = 1) Then
    StartRow = 1
Else
    StartRow = wb.Worksheets(TargetSheetName).Cells(Rows.Count, 1).End(xlUp).Row + 1
End If

'Copy First Sheet
LastRow = SourceWb.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

'Dont copy any data if blank
If LastRow <> 1 Then
    LastColumn = SourceWb.Worksheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
    If StartRow = 1 Then
        Range(SourceWb.Worksheets("Sheet1").Cells(1, 1), SourceWb.Worksheets("Sheet1").Cells(LastRow, LastColumn)).Copy
    Else
        Range(SourceWb.Worksheets("Sheet1").Cells(2, 1), SourceWb.Worksheets("Sheet1").Cells(LastRow, LastColumn)).Copy
    End If

    wb.Worksheets(TargetSheetName).Range("A" + CStr(StartRow)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    TargetLastRow = wb.Worksheets(TargetSheetName).Cells(Rows.Count, 1).End(xlUp).Row
End If



'Copy Second Sheet
LastRow = SourceWb.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row

'Dont copy any data if blank
If LastRow <> 1 Then
    LastColumn = SourceWb.Worksheets("Sheet2").Cells(1, Columns.Count).End(xlToLeft).Column

    'Copy from row 2 to avoid copying headers again
    Range(SourceWb.Worksheets("Sheet2").Cells(2, 1), SourceWb.Worksheets("Sheet2").Cells(LastRow, LastColumn)).Copy
    wb.Worksheets(TargetSheetName).Range("A" + CStr(TargetLastRow + 1)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
End If

SourceWb.Close SaveChanges:=False
End Sub

【问题讨论】：

您可以在部分之前和之后添加 msgbox 命令，然后注意哪个是您在崩溃之前看到的最后一个 msgbox。然后，您可以回到违规线路。当然，显示消息时的暂停本身可能会阻止崩溃 - 在这种情况下，您可以删除错误消息，直到它崩溃
很难说没有看到具体的代码，以及它失败的那一行的信息。请使用您的代码更新您的问题，或者最好使用minimal reproducible example 来重现崩溃。还要确保您使用的是最新版本的 Excel，否则请先更新。包括您的 Excel 版本，如果它是 x86/x64 版本，我认为也是一个好主意。
你还没有解释它是如何“崩溃”的。它只是停止响应吗？当您的代码执行此操作时，应用程序窗口是否可见？您说您将大量数据复制到剪贴板 - 询问是否应将数据保留在剪贴板上的消息是否正在等待答案？
@FreeMan 是的，应用程序在没有警告的情况下关闭。我一直在考虑是否可以不时写入实际文件来解决这个问题。
请注意，但如果您声明Dim SourceWb, wb As Workbook，那么只有wb 被声明为Workbook，但SourceWb 的类型为Variant。您需要为每个变量声明一个类型：Dim SourceWb As Workbook, wb As Workbook。还有LastRow, LastColumn, StartRow, TargetLastRow 应该都是Long 而不是Variant

标签： vba excel crash race-condition

【解决方案1】：

我怀疑这一点

Dim OpenDialog As Office.FileDialog

Set wb = ActiveWorkbook

DataFileName = Dir(TempFilePath)
If Not DataFileName <> "" Then
    MsgBox CustomMessage
    Set OpenDialog = Application.FileDialog(msoFileDialogFilePicker)
    OpenDialog.Filters.Clear
    OpenDialog.Filters.Add "Excel Files", "*.xlsx"
    OpenDialog.AllowMultiSelect = False
    OpenDialog.Show
    TempFilePath = OpenDialog.SelectedItems(1)
End If

用这个替换

Dim s
Set wb = ActiveWorkbook
datafilename = Dir(tempfilepath)
If datafilename = "" Then
s = Application.GetOpenFilename("*.xlsx,Excel Files", 1, "Select File", , False)
If Not s = False Then
    tempfilepath = s
End If
End If

【讨论】：

这些文件通常会一直存在，并且在我的测试运行期间保证有匹配的文件，所以我从来不用选择文件，所以即使这部分可能会导致问题，也会有那么其他问题也是如此。
您每次都在引用 office.filedialog，即使您从未使用过它——我认为这是问题所在。至少在 if 循环中移动暗淡
我尝试删除如果找不到则选择文件的选项并尝试运行它，但不幸的是仍然崩溃。所以要么这不能解决问题，要么存在多个问题。

【解决方案2】：

我可以通过在子 ReadInAndCopyFile 的代码中的两个位置添加 Application.Wait 来解决此问题。

'Firstplace
Workbooks.Open FileName:=TempFilePath, UpdateLinks:=False
Application.Wait (Now + TimeValue("0:00:10"))
Set SourceWb = ActiveWorkbook

'Second place
Application.Wait (Now + TimeValue("0:00:10"))
SourceWb.Close SaveChanges:=False

展示位置仅是由于我认为错误发生的位置。完全有可能只等待一次就足够了，而更短的等待就可以了。我以后可能会做进一步的实验，但现在它已经足够了。

很高兴听到是否有人有更好或更快的方法来解决这个问题，因为这种方法占总运行时间的大量时间。

【讨论】：