优化多CSV文件转置合并至主Excel文件的VBA脚本效率

问题背景 #

我有一个存有数万个CSV文件的目录（这些文件原本是HTML文件，已通过另一VBA脚本修改扩展名），需要合并到名为「Main Import File VBA」的主Excel文件中。因为文件数量极大，必须尽可能提升处理效率。

现有VBA脚本会逐个打开CSV文件，复制A列内容后转置粘贴到主文件，再关闭文件循环处理下一个。但我觉得用Select和Copy操作效率很低，不确定在需要转置的情况下有没有更优的方法；同时也想知道能不能不用打开每个CSV文件就能获取内容。

测试数据：处理25个CSV文件耗时约9.8秒，移除复制转置粘贴步骤后耗时约6.5秒。我没有PowerQuery、HTML解析或数组翻转相关经验。

现有脚本如下：

Sub PutInMasterFile()
    Dim wb          As Workbook
    Dim myMasterFile As String
    Dim masterWB    As Workbook
    Dim rowNum      As Integer
    Dim copyRange   As Range
    Dim pasteRange  As Range
    Dim myPath      As String
    Dim myFile      As String
    Dim FirstAddress As String
    Dim x           As Variant
    Dim C           As Variant
    Application.ScreenUpdating = FALSE
    Application.EnableEvents = FALSE
    Application.Calculation = xlCalculationManual
    Application.DisplayAlerts = FALSE
    x = 2
    myMasterFile = "C:\S_A\VBA Test\Main Import File VBA.xlsm"
    'Workbooks("Main Import File VBA").Activate
    Set pasteRange = ActiveWorkbook.Sheets(1).Range("A" & x)
    myPath = "C:\S_A\VBA Test\Output\"
    myFile = Dir(myPath & "*.csv")
    Start = Timer
    Do While myFile <> vbNullString
        'csv file opened here
        Workbooks.Open Filename:=myPath & myFile
        'selection made for copying the data
        With Workbooks(myFile).Sheets(1)
            Range("A1").Select
            Range(Selection, Selection.End(xlDown)).Select
            Selection.Copy
            pasteRange.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                                    False, Transpose:=True
            'Close the csv file
            Workbooks(myFile).Close
            myFile = Dir()
            x = x + 1
            Set pasteRange = ActiveWorkbook.Sheets(1).Range("A" & x)
        End With
    Loop
    Finish = Timer
    TotalTime = Finish - Start
    MsgBox "Total time is " & TotalTime & " seconds!"
End Sub

核心优化思路 #

• 砍掉Select/Copy/Paste操作：直接用数组读取数据并转置，这是内存级操作，比剪贴板交互快得多，也是测试中耗时最多的环节
• 避免无意义的UI交互：直接绑定工作表和数据范围，不要依赖ActiveWorkbook或Select这类界面状态相关操作
• 可选：跳过打开CSV文件：用文件读取方式直接读内容，适合纯文本格式的CSV，能进一步减少Excel打开文件的开销

改进版代码（易上手，兼容原逻辑） #

这个版本保留打开CSV文件的逻辑，用数组操作替代低效的复制粘贴，适合快速替换原脚本：

Sub OptimizedPutInMasterFile()
    Dim masterWS As Worksheet
    Dim myPath As String, myFile As String
    Dim dataArr As Variant, transposedArr As Variant
    Dim lastRow As Long, i As Long
    Dim targetRow As Long
    Dim wbCSV As Workbook
    
    ' 关闭Excel冗余功能，提速关键
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    
    ' 绑定主文件工作表，避免依赖Active状态
    Set masterWS = ThisWorkbook.Sheets(1) ' 若主文件不是当前运行脚本的文件，改成Workbooks("Main Import File VBA.xlsm").Sheets(1)
    targetRow = 2 ' 从第2行开始写入数据
    
    myPath = "C:\S_A\VBA Test\Output\"
    myFile = Dir(myPath & "*.csv")
    
    Dim Start As Double, Finish As Double
    Start = Timer
    
    Do While myFile <> vbNullString
        ' 只读打开CSV，减少文件锁开销
        Set wbCSV = Workbooks.Open(Filename:=myPath & myFile, ReadOnly:=True)
        With wbCSV.Sheets(1)
            ' 准确获取A列最后一行，避免xlDown遇到空行的问题
            lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
            If lastRow >= 1 Then
                ' 把A列数据读入数组
                dataArr = .Range("A1:A" & lastRow).Value
                
                ' 手动转置数组：单列变单行
                ReDim transposedArr(1 To 1, 1 To UBound(dataArr))
                For i = 1 To UBound(dataArr)
                    transposedArr(1, i) = dataArr(i, 1)
                Next i
                
                ' 直接把数组写入主文件，无需粘贴
                masterWS.Cells(targetRow, "A").Resize(1, UBound(transposedArr, 2)).Value = transposedArr
            End If
        End With
        
        ' 关闭CSV，不保存任何修改
        wbCSV.Close SaveChanges:=False
        myFile = Dir()
        targetRow = targetRow + 1
    Loop
    
    Finish = Timer
    MsgBox "总耗时：" & Round(Finish - Start, 2) & " 秒!"
    
    ' 恢复Excel正常功能
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub

进阶优化：不打开CSV文件直接读取 #

如果想彻底跳过打开CSV文件的步骤，用文件读取方式直接读内容，速度会更快。适合CSV是纯文本、A列无复杂分隔内容的场景：

Sub ReadCSVWithoutOpening()
    Dim masterWS As Worksheet
    Dim myPath As String, myFile As String
    Dim fileNum As Integer
    Dim lineText As String, dataArr As Variant
    Dim targetRow As Long
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    
    Set masterWS = ThisWorkbook.Sheets(1)
    targetRow = 2
    
    myPath = "C:\S_A\VBA Test\Output\"
    myFile = Dir(myPath & "*.csv")
    
    Dim Start As Double, Finish As Double
    Start = Timer
    
    Do While myFile <> vbNullString
        fileNum = FreeFile()
        ' 打开CSV文件读内容
        Open myPath & myFile For Input As #fileNum
        
        ' 一次性读取所有行，转成数组
        dataArr = Split(Input$(LOF(fileNum), fileNum), vbCrLf)
        Close #fileNum
        
        ' 过滤掉空行
        dataArr = Filter(dataArr, "", False)
        
        ' 直接写入主文件，数组天然是单行格式，无需额外转置
        If UBound(dataArr) >= 0 Then
            masterWS.Cells(targetRow, "A").Resize(1, UBound(dataArr) + 1).Value = dataArr
        End If
        
        myFile = Dir()
        targetRow = targetRow + 1
    Loop
    
    Finish = Timer
    MsgBox "总耗时：" & Round(Finish - Start, 2) & " 秒!"
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub

优化效果说明 #

• 数组操作版本：预计能把25个文件的处理时间从9.8秒压缩到7秒以内，主要砍掉了复制粘贴的开销
• 直接读文件版本：处理时间能进一步降到6秒左右，接近移除粘贴步骤后的耗时，彻底避免了打开Excel文件的开销

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