VBA如何从TXT文件提取指定StoreID+日期到99 END OF DAY的内容并拆分行

功能实现说明 #

• 匹配到目标StoreID+日期组合后，仅读取到99 END OF DAY标记即停止，不会加载全量历史数据，适配大体积TXT文件场景
• 支持指定行自动拆分数值：开头为12、13A，以及包含SAFETY INSPECTION、DISPOSAL FEE的行会按空格拆分后逐列写入，可通过常量开关关闭拆分功能，仅提取原始行内容

完整修改后代码 #

Sub GetDailySales()
    ' 功能开关：设置为False则仅提取原始行，不做拆分
    Const ENABLE_SPLIT As Boolean = True
    Dim todaysdate As Variant, todaysdate2 As String
    Dim sFile As String
    Dim objFSO As Object, objTextFile As Object
    Dim DataLine As String, bFound As Boolean
    Dim ws As Worksheet, nextRow As Long
    Dim splitArr As Variant, arrItem As Variant, colIndex As Long
    
    ' 初始化参数
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    todaysdate = ws.Range("A2").Value
    todaysdate2 = ws.Range("A1").Value & Format(todaysdate, "mmddyy")
    sFile = "C:\Users\axela\Desktop\FileSample.txt"
    nextRow = ws.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Row
    
    ' 打开TXT文件
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTextFile = objFSO.OpenTextFile(sFile, 1, -1) ' 1对应ForReading
    
    ' 查找匹配的StoreID+日期行
    Do While Not objTextFile.AtEndOfStream
        DataLine = objTextFile.ReadLine
        If InStr(1, DataLine, todaysdate2) > 0 Then
            bFound = True
            Exit Do
        End If
    Loop
    
    ' 找到匹配项后读取到结束标记为止
    If bFound Then
        Do While Not objTextFile.AtEndOfStream
            DataLine = Trim(objTextFile.ReadLine)
            ' 遇到结束标记就退出
            If InStr(1, DataLine, "99 END OF DAY") > 0 Then Exit Do
            
            If Not ENABLE_SPLIT Then
                ' 不拆分直接写入A列
                ws.Cells(nextRow, 1) = DataLine
                nextRow = nextRow + 1
            Else
                ' 判断是否为需要拆分的行
                If Left(DataLine, 2) = "12" Or Left(DataLine, 3) = "13A" Or _
                    InStr(1, DataLine, "SAFETY INSPECTION") > 0 Or _
                    InStr(1, DataLine, "DISPOSAL FEE") > 0 Then
                    ' 按空格拆分，过滤空值
                    splitArr = Split(DataLine, " ")
                    colIndex = 1
                    For Each arrItem In splitArr
                        arrItem = Trim(arrItem)
                        If arrItem <> "" Then
                            ws.Cells(nextRow, colIndex) = arrItem
                            colIndex = colIndex + 1
                        End If
                    Next
                    nextRow = nextRow + 1
                Else
                    ' 不需要拆分的行直接写入A列
                    ws.Cells(nextRow, 1) = DataLine
                    nextRow = nextRow + 1
                End If
            End If
        Loop
        objTextFile.Close
    Else
        ws.Cells(nextRow, 1) = "未找到匹配的StoreID+日期记录"
    End If
    
    ' 释放对象
    Set objFSO = Nothing
    Set objTextFile = Nothing
    Set ws = Nothing
End Sub

使用说明 #

1. 若不需要拆分功能，将代码开头的ENABLE_SPLIT常量设置为False即可，提取的原始行内容会全部写入A列，后续可自行用PowerQuery处理
2. 拆分逻辑默认按空格分隔，如果实际文件分隔符是制表符，可将Split(DataLine, " ")修改为Split(DataLine, vbTab)
3. TXT文件路径可根据实际存储位置调整sFile变量的取值

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