Question

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

该问题似乎与打开文件，复制大量数据，然后关闭文件有关。但我不确定程序实际崩溃的位置。有关调试/查找代码错误发生位置的方法的提示将非常受欢迎。

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

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

我认为将数据保存到cliboard是个问题，并添加了

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

Answer 2

我能够通过在SubInRendCopyFile的代码中的两个位置添加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

这个展示位置只是因为我认为错误发生的地方。完全有可能只有一次等待就足够了，等待时间更短就可以了。我可能会在以后做进一步的实验，但现在它已经足够运行了。

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

VBA应用程序崩溃没有错误消息 - 在单步执行程序时工作

2 个答案: