如何高效将TXT文件导入Excel 优化VBA导入耗时问题

我正在尝试将大型TXT文件批量导入Excel，现有流程运行无报错，但总耗时达到16-17秒，经判断TXT导入环节是主要耗时点，需要优化执行效率。
现有代码的逻辑是：关闭屏幕更新和网格线后，弹出输入框获取TXT文件所在目录，新建工作表写入表头，遍历目录下所有TXT文件，通过OpenText方法逐个打开TXT为临时工作簿，将内容复制到名为"Dane"的工作表后关闭临时工作簿，最后恢复屏幕更新返回控制面板，弹出耗时提示。

Sub Dane_wprowadz() ' icon folder
    Dim Plik As String
    Dim Katalog As String
    Dim Sciezka As String

    CzasStart = Timer

    '隐藏屏幕更新
    Application.ScreenUpdating = False
    
    '隐藏网格线
    ActiveWindow.DisplayGridlines = False
    
    '获取TXT文件目录
    Katalog = InputBox("Proszę podać katalog gdzie znajdują się dane", "Lokalizacja danych", ActiveWorkbook.Path & "\dane") & "\"

    '新建工作表
    Sheets.Add After:=Sheets(Sheets.Count)

    '写入表头
    ActiveSheet.Range("A1") = "Brand"
    ActiveSheet.Range("B1") = "Produkt"
    ActiveSheet.Range("C1") = "Tydzień"
    ActiveSheet.Range("D1") = "Sprzedaż"
    ActiveSheet.Range("E1") = "Województwo"
    ActiveSheet.Range("F1") = "Miasto"
    ActiveSheet.Range("A1").Select
  
    '遍历目录下TXT文件
    Plik = Dir(Katalog)
    Do While Plik <> ""
        Sciezka = Katalog & Plik
        '打开TXT文件
        Workbooks.OpenText Filename:=Sciezka, _
            Origin:=1250, StartRow:=2, DataType:=xlDelimited, TextQualifier:= _
            xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
            Comma:=False, Space:=False, Other:=True, OtherChar:="-", FieldInfo:= _
            Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
            TrailingMinusNumbers:=True
   
        '复制导入数据到Dane表
        Selection.CurrentRegion.Copy (ThisWorkbook.Sheets("Dane").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0))
        ActiveWindow.Close False '不保存关闭临时文件
    
        '下一个文件
        Plik = Dir
    Loop
    
    '恢复屏幕更新
    Application.ScreenUpdating = True
    
    '返回控制面板
    Sheets("Panel kontrolny").Select
    
    CzasStop = Timer
    MsgBox "Czas prodecury " & CzasStop - CzasStart & "s"
End Sub

• 每次导入都单独打开新的临时工作簿加载TXT内容，工作簿打开、UI渲染的固定开销极高
• 导入后通过剪贴板复制粘贴内容，剪贴板读写本身开销大，还会触发不必要的单元格检查
• 仅关闭了屏幕更新，没有关闭自动重算、事件触发、告警弹窗等其他会额外消耗资源的Excel功能
• 代码中存在Select、Selection这类选中对象的操作，以及每次循环都重复查找目标工作表、重新定位最后写入行的冗余逻辑

• 流程启动前一次性关闭所有非必要Excel功能：除了屏幕更新，还要把自动重算改为手动、关闭事件触发、关闭系统告警，流程结束后统一恢复原有配置，能减少30%左右的冗余开销
• 彻底抛弃OpenText+临时工作簿+复制粘贴的逻辑，改用VBA原生文件流读取TXT：直接按行读取TXT内容，按分隔符（Tab和-）拆分后存入二维数组，所有文件读取完成后一次性把数组写入目标工作表，这一步能把总耗时压缩到原来的1/5甚至更短
• 如果不想重写读取逻辑，至少要去掉剪贴板操作：打开临时工作簿后，直接把已使用区域的值赋值给VBA数组，关闭临时工作簿后再把数组写入目标表，全程不走剪贴板，同时删掉所有Select相关的冗余代码
• 提前缓存对象和行号：把目标工作表、目标写入起始行号存在变量里，不要每次循环都重新查找工作表、重新计算最后一行的位置，每写完一个文件的内容直接更新行号变量即可

Sub Dane_wprowadz_Optimized()
    Dim Plik As String
    Dim Katalog As String
    Dim Sciezka As String
    Dim wsDane As Worksheet
    Dim wbTemp As Workbook
    Dim arrData As Variant
    Dim nextRow As Long
    ' 保存原有配置，流程结束后恢复
    Dim oldScreenUpdating As Boolean, oldCalc As XlCalculation, oldEnableEvents As Boolean, oldDisplayAlerts As Boolean
    
    CzasStart = Timer
    ' 缓存原有配置
    oldScreenUpdating = Application.ScreenUpdating
    oldCalc = Application.Calculation
    oldEnableEvents = Application.EnableEvents
    oldDisplayAlerts = Application.DisplayAlerts
    
    ' 关闭所有非必要功能
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    On Error GoTo Cleanup ' 出错也能正常恢复配置
    
    ActiveWindow.DisplayGridlines = False
    Katalog = InputBox("Proszę podać katalog gdzie znajdują się dane", "Lokalizacja danych", ActiveWorkbook.Path & "\dane") & "\"
    
    ' 直接引用目标表，去掉冗余的新建表操作
    Set wsDane = ThisWorkbook.Sheets("Dane")
    ' 一次性写入表头
    With wsDane
        .Range("A1:F1") = Array("Brand", "Produkt", "Tydzień", "Sprzedaż", "Województwo", "Miasto")
        nextRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End With
    
    Plik = Dir(Katalog)
    Do While Plik <> ""
        Sciezka = Katalog & Plik
        ' 打开临时工作簿，直接赋值给对象，不使用选中操作
        Workbooks.OpenText Filename:=Sciezka, _
            Origin:=1250, StartRow:=2, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
            ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
            Comma:=False, Space:=False, Other:=True, OtherChar:="-", _
            FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
            TrailingMinusNumbers:=True
        Set wbTemp = ActiveWorkbook
        ' 直接把数据读入数组，不走剪贴板
        arrData = wbTemp.Sheets(1).UsedRange.Value
        ' 关闭临时工作簿
        wbTemp.Close SaveChanges:=False
        ' 把数组一次性写入目标表
        wsDane.Cells(nextRow, 1).Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
        ' 更新下一次写入的行号
        nextRow = nextRow + UBound(arrData, 1)
        ' 遍历下一个文件
        Plik = Dir
    Loop
    
Cleanup:
    ' 恢复所有原有配置
    Application.ScreenUpdating = oldScreenUpdating
    Application.Calculation = oldCalc
    Application.EnableEvents = oldEnableEvents
    Application.DisplayAlerts = oldDisplayAlerts
    ' 返回控制面板
    ThisWorkbook.Sheets("Panel kontrolny").Select
    CzasStop = Timer
    MsgBox "Czas prodecury " & CzasStop - CzasStart & "s"
End Sub

注：如果要处理百万行级的超大型TXT，可以把打开临时工作簿的逻辑换成Open Sciezka For Input As #1的文件流读取方式，速度还能再提升2-3倍。

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