VBA导出宏优化求助：运行卡顿且偶发Excel崩溃问题

优化后的完整代码 #

Option Explicit

Sub Acto_Export_Optimized()
    ' 应用级性能优化设置
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    
    Dim srcWb As Workbook
    Dim srcWs As Worksheet
    Dim destWb As Workbook
    Dim destWs As Worksheet
    Dim sFolder As String
    Dim projectNumber As String
    Dim lastRow As Long
    Dim srcData As Variant
    Dim destData As Variant
    Dim i As Long
    Dim destRow As Long
    
    ' 绑定源工作簿和工作表，避免反复索引查找
    Set srcWb = ActiveWorkbook
    Set srcWs = srcWb.ActiveSheet
    
    ' 选择保存文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            sFolder = .SelectedItems(1)
        Else
            MsgBox "未选择文件夹，操作终止"
            GoTo Cleanup
        End If
    End With
    
    ' 仅验证一次项目号，避免循环内重复执行
    projectNumber = srcWs.Cells(4, 3).Value
    If Len(projectNumber) <> 8 Or Not IsNumeric(projectNumber) Then
        MsgBox "项目号无效，请输入8位数字。操作终止。"
        GoTo Cleanup
    End If
    
    ' 创建目标工作簿并绑定工作表，提前重命名减少后续操作
    Set destWb = Workbooks.Add
    Set destWs = destWb.Sheets(1)
    destWs.Name = "PLN961"
    
    ' 批量写入表头，替代逐单元格赋值
    destWs.Range("A1:L1").Value = Array( _
        "project nummer", "activiteit", "activiteit naam", _
        "activiteit soort", "bouwdeel", "bouwdeel omschrijving", _
        "bouwdeel zoeknaam", "activiteit soort naam", _
        "zoeknaam activiteit soort", "categorie", "categorie naam", _
        "Projectdeel" _
    )
    
    ' 直接设置单元格格式，移除冗余Select操作
    With destWs
        .Columns("B:L").NumberFormat = "000000"
        .Columns("E,E,I,J,L").NumberFormat = "0"
    End With
    
    ' 获取源数据最后一行，批量读取到内存数组
    lastRow = srcWs.Cells(srcWs.Rows.Count, 2).End(xlUp).Row
    If lastRow < 9 Then
        MsgBox "无有效数据可导出"
        GoTo Cleanup
    End If
    srcData = srcWs.Range("A9:F" & lastRow).Value ' 仅读取需要的列，减少内存占用
    
    ' 先统计符合条件的记录数，初始化目标数组
    destRow = 1
    For i = 1 To UBound(srcData, 1)
        If LCase(srcData(i, 1)) = "x" Then
            destRow = destRow + 1
        ElseIf srcData(i, 1) <> "" Then
            MsgBox "第" & (i + 8) & "行输入错误，请仅使用X或空值。操作终止。"
            destWb.Close SaveChanges:=False
            GoTo Cleanup
        End If
    Next i
    
    ReDim destData(1 To destRow, 1 To 12)
    ' 复制表头到目标数组
    For i = 1 To 12
        destData(1, i) = destWs.Cells(1, i).Value
    Next i
    
    ' 在内存数组中填充数据，避免逐单元格写入工作表
    destRow = 2
    For i = 1 To UBound(srcData, 1)
        If LCase(srcData(i, 1)) = "x" Then
            destData(destRow, 1) = projectNumber
            destData(destRow, 2) = "00" & srcData(i, 2)
            destData(destRow, 3) = srcData(i, 6)
            destData(destRow, 4) = "00" & srcData(i, 2)
            destData(destRow, 5) = "0"
            destData(destRow, 6) = "algemeen"
            destData(destRow, 7) = "alg"
            destData(destRow, 8) = srcData(i, 6)
            destData(destRow, 9) = Left(srcData(i, 6), 2)
            destData(destRow, 10) = "0"
            destData(destRow, 11) = "algemeen"
            destData(destRow, 12) = "0"
            
            destRow = destRow + 1
        End If
    Next i
    
    ' 批量将数组写入工作表，大幅提升速度
    destWs.Range("A1:L" & UBound(destData, 1)).Value = destData
    
    ' 保存文件
    Dim exportFileName As String
    exportFileName = sFolder & "\" & Format(Now, "yyyy-MM-dd_HHmmss_") & projectNumber & "_importfileActo.xlsx"
    destWb.SaveAs exportFileName
    
    MsgBox "导出完成！文件已保存至：" & exportFileName

Cleanup:
    ' 恢复Excel默认设置，避免影响后续操作
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
    
    ' 清理对象释放内存
    Set srcWs = Nothing
    Set srcWb = Nothing
    Set destWs = Nothing
    Set destWb = Nothing
End Sub

核心优化点说明 #

1. 应用级性能开关 #

• 新增EnableEvents = False：禁止触发工作表事件（如Change、SelectionChange），减少后台无效操作
• 新增Calculation = xlCalculationManual：暂停自动计算，避免每次写入数据时重新计算整个工作表
• 新增DisplayAlerts = False：关闭保存、删除等操作的确认弹窗，减少交互等待

2. 直接绑定工作表对象 #

• 用Set srcWs = srcWb.ActiveSheet绑定源工作表，Set destWs = destWb.Sheets(1)绑定目标工作表，替代原代码中反复通过文件名、表名索引查找的方式，大幅减少对象访问开销

3. 批量数据处理（数组替代逐单元格写入） #

• 将源数据一次性读取到内存数组srcData，目标数据先在数组destData中填充完成，最后一次性写入工作表
• 数组操作在内存中执行，比逐单元格读写工作表快10-100倍，是解决卡顿、崩溃的核心优化

4. 减少重复检查 #

• 原代码在循环内每次都检查项目号，优化后仅在循环前检查1次，避免无意义的重复执行
• 提前统计符合条件的记录数，避免数组空间浪费

5. 移除所有Select操作 #

• 原代码中Columns("B:L").Select这类操作会触发Excel界面更新，优化后直接通过destWs.Columns("B:L").NumberFormat操作Range对象，提升速度同时避免界面闪烁

6. 完善错误处理流程 #

• 新增Cleanup标签，确保无论操作成功或失败，都能恢复Excel的默认设置，避免后续操作异常
• 提前判断源数据是否为空，避免无效循环

内容的提问来源于stack exchange，提问作者anton kruizinga