如何优化Excel VBA导入代码以提升运行速度？

阿华AIGC实验室

2026-5-15

优化VBA导入流程，大幅提升运行速度的技巧

嘿，很高兴看到你已经让代码正常运行了！不过导入速度慢确实是个头疼的问题，咱们来一步步拆解你的代码，找出拖慢速度的核心点，然后给你针对性的优化方案——按照这些方法调整后，小文件的导入时间应该能从5分钟压缩到几秒，大文件的耗时也会大幅降低。

核心优化方向及具体操作

1. 全程锁定性能相关设置，避免中途反复切换

你代码里中途把Application.ScreenUpdating重新设为True了，这会让Excel每次单元格操作都刷新屏幕，直接拖慢速度。另外，还要禁用事件触发，避免不必要的宏或公式触发，全程保持手动计算。

修正代码片段：

Sub Figures()
    ' 开头就锁定所有影响性能的设置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = False
    
    ' ... 你的其他代码 ...
    
    ' 最后再统一恢复所有设置
fin:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    ' ... 后续收尾代码 ...
End Sub

2. 彻底抛弃`Activate`/`Select`，用对象变量直接操作

频繁切换窗口、选中工作表/单元格是VBA性能的头号杀手——每一次切换都要和Excel的界面交互，耗时极长。你应该直接用变量引用目标工作簿和工作表，全程无需切换界面。

修正示例：

' 提前定义对象变量
Dim sourceWb As Workbook
Dim wsSource As Worksheet, wsDest As Worksheet, wsLP As Worksheet

' 直接引用目标工作表，无需切换
Set wsDest = ThisWorkbook.Worksheets("Dest")
Set wsLP = ThisWorkbook.Worksheets("LP")

' 打开单个文件时直接赋值对象，不用Activate
Set sourceWb = Workbooks.Open(Filename:=NomFichier(o)) ' 注意：这里要循环处理每个选中的文件，不是拼接的路径字符串！
Set wsSource = sourceWb.Worksheets("DataBase")

' 后续所有操作直接用变量，比如：
n = wsDest.Range("L" & wsDest.Rows.Count).End(xlUp).Row + 1
debutcols = CInt(wsSource.Cells(1, 22).Value)

3. 批量读写数据，替换逐单元格循环

你现在用三层循环逐单元格读写数据，这是最慢的方式。VBA和Excel对象模型的交互成本很高，一次性把数据读到数组，再一次性写入目标区域，能把循环次数从几万次降到几次。

优化读写逻辑：

' 读取源数据到数组（从行1823到1822+rowmaxwallets，列debutas到finas）
Dim sourceData As Variant
sourceData = wsSource.Range(wsSource.Cells(1823, debutas), wsSource.Cells(1822 + rowmaxwallets, finas)).Value

' 一次性写入目标工作表（从行n，列debutad开始，匹配数组的行数和列数）
wsDest.Cells(n, debutad).Resize(UBound(sourceData, 1), UBound(sourceData, 2)).Value = sourceData

' 直接更新行号，无需逐行加1
n = n + UBound(sourceData, 1)

4. 修复多文件处理的逻辑bug

你代码里把所有选中的文件路径拼接成Msg，然后用Workbooks.Open Filename:=Msg打开——这明显是错误的，会导致Excel尝试打开一个不存在的文件（多个路径连在一起的字符串），这不仅会报错，也会额外消耗性能。

正确的多文件处理逻辑：

' 先确认选中的文件
Config = vbYesNo + vbInformation + vbDefaultButton2
For o = LBound(NomFichier) To UBound(NomFichier)
    Msg = Msg & NomFichier(o) & vbCrLf
Next o
Reponse = MsgBox("Please find below your files :" & vbCrLf & Msg & vbCrLf, Config, "MAJ resum")
If Reponse = vbNo Then GoTo TheEnd

' 逐个处理每个选中的文件
For o = LBound(NomFichier) To UBound(NomFichier)
    Set sourceWb = Workbooks.Open(Filename:=NomFichier(o))
    Set wsSource = sourceWb.Worksheets("DataBase")
    
    ' ... 这里写该文件的导入逻辑 ...
    
    ' 处理完关闭文件，释放对象
    sourceWb.Close SaveChanges:=False
    Set sourceWb = Nothing
    Set wsSource = Nothing
Next o

5. 简化列号查找逻辑

你用循环30次找最后一列的方式可以简化，直接用Excel的内置功能找最后一个非空列：

' 找源文件第一行最后一个非空列（年份列的最后一列）
finas = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
fincols = CInt(wsSource.Cells(1, finas).Value)

' 找Dest表中对应起始年份的列
debutcold = wsDest.Rows(1).Find(What:=debutcols, LookIn:=xlValues, LookAt:=xlWhole).Column
debutad = debutcold
finad = debutad + (finas - debutas)

整合后的优化代码示例

Option Explicit
Public Namepatch3 As String

Sub Figures()
    Dim Filt As String
    Dim IndexFiltre As Integer, NomFichier As Variant, Titre As String
    Dim o As Integer
    Dim Msg As String
    Dim Reponse As Integer
    Dim Config As Integer
    Dim sourceWb As Workbook
    Dim wsDest As Worksheet, wsLP As Worksheet, wsSource As Worksheet
    Dim n As Long
    Dim debutcols As Integer, fincols As Integer
    Dim debutas As Integer, finas As Integer
    Dim debutcold As Integer, finad As Integer
    Dim rowmaxwallets As Long
    Dim sourceData As Variant
    
    ' 初始化性能设置
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = False
    
    Namepatch3 = ThisWorkbook.Name
    Set wsDest = ThisWorkbook.Worksheets("Dest")
    Set wsLP = ThisWorkbook.Worksheets("LP")
    
    ' 获取初始行号
    n = wsDest.Range("L" & wsDest.Rows.Count).End(xlUp).Row + 1
    
    ' 文件选择对话框
    Filt = "txt files (*.txt),*.txt," & _
           "Lotus files (*.prn),*.prn," & _
           "Comma separated files (*.csv),*.csv," & _
           "ASCII files (*.asc),*.asc," & _
           "All files (*.*),*.*"
    IndexFiltre = 5
    Titre = "Sélectionner les fichiers à traiter"
    NomFichier = Application.GetOpenFilename _
        (fileFilter:=Filt, _
         FilterIndex:=IndexFiltre, _
         Title:=Titre, _
         MultiSelect:=True)
    
    ' 取消选择的情况
    If Not IsArray(NomFichier) Then
        MsgBox "No files were selected!"
        GoTo TheEnd
    End If
    
    ' 确认选中的文件
    Config = vbYesNo + vbInformation + vbDefaultButton2
    For o = LBound(NomFichier) To UBound(NomFichier)
        Msg = Msg & NomFichier(o) & vbCrLf
    Next o
    Reponse = MsgBox("Please find below your files :" & vbCrLf & Msg & vbCrLf, Config, "MAJ resum")
    If Reponse = vbNo Then GoTo TheEnd
    
    ' 逐个处理文件
    For o = LBound(NomFichier) To UBound(NomFichier)
        ' 打开源文件
        Set sourceWb = Workbooks.Open(Filename:=NomFichier(o))
        Set wsSource = sourceWb.Worksheets("DataBase")
        
        ' 获取源文件的年份列范围
        debutas = 22
        debutcols = CInt(wsSource.Cells(1, debutas).Value)
        finas = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
        fincols = CInt(wsSource.Cells(1, finas).Value)
        
        ' 获取目标文件的对应列范围
        debutcold = wsDest.Rows(1).Find(What:=debutcols, LookIn:=xlValues, LookAt:=xlWhole).Column
        debutad = debutcold
        finad = debutad + (finas - debutas)
        
        ' 获取源数据行数
        rowmaxwallets = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row
        
        ' 批量读取源数据
        sourceData = wsSource.Range(wsSource.Cells(1823, debutas), wsSource.Cells(1822 + rowmaxwallets, finas)).Value
        
        ' 批量写入目标数据
        wsDest.Cells(n, debutad).Resize(UBound(sourceData, 1), UBound(sourceData, 2)).Value = sourceData
        
        ' 更新行号
        n = n + UBound(sourceData, 1)
        
        ' 关闭源文件
        sourceWb.Close SaveChanges:=False
        Set sourceWb = Nothing
        Set wsSource = Nothing
    Next o
    
    ' 完成提示
    MsgBox ("Import done")
    wsDest.Select
    wsDest.Range("A3").Select

TheEnd:
    ' 恢复性能设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    
    ' 释放对象
    Set wsDest = Nothing
    Set wsLP = Nothing
End Sub