Excel 运行宏时随机崩溃

Question

我在使用以下代码时遇到问题，它应该按顺序打开〜100 个 csv 文件，检查单元格中的值（验证，如果它是具有正确结构的文件），复制单行数据并将其粘贴到 ThisWorkbook.Worksheets("2 CSV").Range("B" & row_number).

直到这个月，这个解决方案已经工作了两年。现在整个 Excel 在任何文件上随机崩溃，没有任何错误消息。有时它设法循环遍历 20 个文件，有时是 5 个。

最奇怪的是，我可以使用 F8 手动循环整个过程，没有任何问题。

宏：

Sub b_load_csv()

Dim appStatus           As Variant
Dim folder_path         As String       'folder path to where CSVs are stored
Dim file_name           As String       'file name of current CSV file
Dim row_number          As Integer      'row number in target sheet
Dim source_sheet_name   As String       'name of the source sheet of the CSV = CSV file name
Dim wb_src              As Workbook     'variable for opened CSV source workbook
Dim sht_src             As Worksheet    'variable for opened CSV source sheet
Dim sht_csv             As Worksheet    'variable for target sheet in ThisWorkbook

With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .DisplayAlerts = False
    If .StatusBar = False Then appStatus = False Else appStatus = .StatusBar 'show currently processing file in status bar
End With

folder_path = "C:\Folder\SubFolder\"            'here are the files stored
file_name = Dir(folder_path & "*.csv")          'using dir to get file names
row_number = 3                                  'row number for pasting values
Set sht_csv = ThisWorkbook.Worksheets("2 CSV")  'target sheet for data aggregation

Do While file_name <> ""
    Workbooks.Open (folder_path & file_name), UpdateLinks:=False, Local:=True   'open csv file
    Set wb_src = Workbooks(file_name)                                           'assign opened csv file to variable
    source_sheet_name = Left(file_name, InStr(file_name, ".") - 1)              'sheet name in csv is the same as the file name
    Set sht_src = wb_src.Worksheets(source_sheet_name)                          'assign source sheet to variable
    
    If sht_src.Range("C1").Value2 = "OJ_POPIS" Then     'checks if the csv has the correct structure
        sht_src.Range("A2:FZ2").Copy                    'if so copies desired range
        sht_csv.Range("B" & row_number).PasteSpecial    'and pastes it into target worksheet column B
    End If
    
    sht_csv.Range("A" & row_number).Value2 = file_name  'writes file name into column A
    Application.CutCopyMode = False
    wb_src.Close SaveChanges:=False
    file_name = Dir()   'fetch next file name
    row_number = row_number + 1
    
    'the following lines is what I tried to fix the problem of random excel crashing
    Set wb_src = Nothing
    Set sht_src = Nothing
    Application.StatusBar = "Processing file " & file_name
    DoEvents
    Application.Wait (Now + TimeValue("0:00:02"))
    ThisWorkbook.Save 'save after every loaded file to see which files are causing the problem
Loop

MsgBox "Data from CSV files copied", vbOKOnly

Set sht_csv = Nothing

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

End Sub

源 CSV 文件以 UTF-8 和 ANSI（我的 ACP 是 ANSI, 1250）和 ; 分隔编码。

限制宏的组策略不适用于我。我可以签署自己的宏。

我试过的：

循环结束时的代码行数
识别并删除触发崩溃的文件（它们没有任何共同点，看似随机，到删除一半时......有什么意义）
简化宏
新建工作簿
不同的机器
VPN On/Off

感谢您的帮助！

Answer 1

我要尝试的第一件事是包括一个正确的错误处理程序（接下来不是恢复），特别是对于 x64，并确保在工具/选项/常规中选择 'Break on all unhandled errors'。

我要尝试的第二件事是避免使用剪贴板 -

With sht_src.Range("A2:FZ2")
    sht_cvs.Range("B" & row_number).Resize(.Rows.Count, .Columns.Count).Value = .Value
End With

（无需清除 CutCopyMode）

我要尝试的第三件事是不要使用 Dir 进行过滤，而是像这样 -

sFilter = "*.cvs"
file_name = Dir$(, 15)    ' without vbDirectory if not getting subfolders
Do While Len(file_name)
    If file_name Like sFilter Then
        ' process file
    End If
    file_name = Dir$(, 15)
Loop

我要尝试的第四件事是喝杯好咖啡！

Excel 运行宏时随机崩溃

Excel crashing randomly when running macro

csv

excel

vba

loops

Excel 运行 宏时随机崩溃

Excel crashing randomly when running macro

csv

excel

vba

loops

Excel 运行宏时随机崩溃