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

Question

我有一个 Excel 应用程序，正常运行时经常(但并非总是)崩溃。如果您设置断点并单步执行程序，它永远不会失败。同样，如果您在关键位置设置断点，然后继续执行，通常效果也很好。

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

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

编辑:正常运行应用程序时，它的运行时间似乎比您预期的要长，然后就关闭了，没有任何错误消息。我在 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

Answer 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