如何修改VBA代码实现批量提取多个TXT文件指定数据到Excel

你只需要将原有单文件逻辑包裹进多文件遍历循环即可，修改后的完整代码如下：

Sub onlinecharges()
    ' 先新建存储结果的工作簿
    Workbooks.Add
    Dim ws As Worksheet
    Set ws = ActiveWorkbook.Sheets(1)
    ' 定义变量
    Dim filePaths As Variant, text As String, textline As String, po_charges As Long
    Dim i As Long, currentRow As Long
    currentRow = 2 ' 初始写入行从第2行开始
    
    ' 开启多文件选择
    filePaths = Application.GetOpenFilename(FileFilter:="文本文件 (*.txt), *.txt", MultiSelect:=True)
    
    ' 判断用户是否选中了文件
    If IsArray(filePaths) = False Then
        MsgBox "未选中任何文件，程序退出"
        Exit Sub
    End If
    
    ' 遍历所有选中的文件
    For i = LBound(filePaths) To UBound(filePaths)
        text = "" ' 每次处理新文件清空文本内容
        ' 打开文件读取内容
        Open filePaths(i) For Input As #1
        Do Until EOF(1)
            Line Input #1, textline
            text = text & textline
        Loop
        Close #1
        
        ' 匹配NET CHARGES位置
        po_charges = InStr(text, "NET CHARGES")
        ' 写入文件名
        ws.Cells(currentRow, 1).Value = Dir(filePaths(i))
        ' 写入提取的数值，加判断避免匹配不到时报错
        If po_charges > 0 Then
            ws.Cells(currentRow, 2).Value = Abs(Mid(text, po_charges + 88, 8))
        Else
            ws.Cells(currentRow, 2).Value = "未匹配到对应内容"
        End If
        ' 行号累加，下一个文件写入下一行
        currentRow = currentRow + 1
    Next i
    
    ' 可选：自动调整A、B列列宽
    ws.Columns("A:B").AutoFit
End Sub

核心修改说明 #

• 原单文件选择逻辑调整为多文件选择，通过MultiSelect:=True参数允许用户同时选中多个文本文件，返回的选中文件路径存储为数组
• 新增循环遍历所有选中的文件路径，原有单文件的读取、匹配、提取逻辑完全保留在循环内部
• 新增行号计数器currentRow，每处理完一个文件自动加1，实现结果依次写入A2、B2往下的单元格
• 新增匹配不到内容的容错逻辑，避免程序报错中断

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