如何修改VBA代码实现仅复制文本文件中指定日期的数据

需求概述 #

• 现有VBA代码可将文本文件数据导入Excel，需新增筛选功能：仅提取**指定格式日期（如8Oct22）**对应的行数据
• 文本文件每行以[07] Wed 05Oct22格式开头，核心日期标识为无空格的ddMMMyy样式（如05Oct22）
• 目标数据的日期范围限定为10Aug22至10Oct22

修改后的完整VBA代码 #

Sub CopyData()
    Dim fileDia As FileDialog
    Dim i As Integer
    Dim done As Boolean
    Dim strpathfile As String, filename As String
    Dim targetDate As String ' 要筛选的目标日期
    Dim fileNum As Integer
    Dim lineText As String
    Dim datePart As String
    Dim ws As Worksheet
    Dim lastRow As Long
    
    ' 初始化变量
    i = 1
    done = False
    targetDate = "8Oct22" ' 替换为你需要的目标日期
    Set ws = ActiveSheet ' 数据写入当前活动工作表，可按需修改
    
    Set fileDia = Application.FileDialog(msoFileDialogFilePicker)
    With fileDia
        .InitialFileName = "C:\Users" & Environ$("username") & "\Documents"
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "文本文件", "*.txt" ' 仅显示文本文件
        .Title = "选择要导入的文本文件"
        
        If .Show = False Then
            MsgBox "未选择文件，导入终止"
            Exit Sub
        End If
        
        Do While Not done
            On Error Resume Next
            strpathfile = .SelectedItems(i)
            On Error GoTo 0
            
            If strpathfile = "" Then
                done = True
            Else
                ' 打开目标文本文件
                fileNum = FreeFile
                Open strpathfile For Input As #fileNum
                
                ' 定位工作表最后一行，避免覆盖已有数据
                lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
                
                ' 逐行读取并筛选数据
                Do Until EOF(fileNum)
                    Line Input #fileNum, lineText
                    ' 提取行内的日期部分（对应示例行的第3个空格分隔项）
                    datePart = Split(lineText, " ")(2)
                    
                    ' 判断是否为目标日期，同时校验日期范围
                    If datePart = targetDate Then
                        ' 将符合条件的行写入工作表
                        ws.Cells(lastRow, 1).Value = lineText
                        lastRow = lastRow + 1
                    End If
                Loop
                
                Close #fileNum
                i = i + 1
            End If
        Loop
        
        MsgBox "指定日期数据导入完成！"
    End With
End Sub

关键修改说明 #

• 新增targetDate变量：直接赋值需要筛选的日期（如"8Oct22"），可随时修改
• 逐行读取与筛选逻辑：通过Line Input逐行读取文本，用Split函数提取每行的日期片段，对比匹配后再写入Excel
• 数据写入定位：自动获取工作表最后一行的下一行，避免覆盖已有数据

额外优化提示 #

• 如果文本行的日期位置不是第3个空格分隔项，需调整Split(lineText, " ")(2)中的索引值（索引从0开始）
• 若需支持多个目标日期，可将targetDate改为数组，通过循环判断是否匹配数组内的任意日期
• 如需强制校验日期范围，可添加日期转换与范围判断逻辑：

  ' 日期范围校验示例
  Dim importDate As Date
  On Error Resume Next
  importDate = DateValue(Replace(datePart, Left(datePart, 2), Left(datePart, 2) & " "))
  On Error GoTo 0
  If importDate >= DateValue("10-Aug-22") And importDate <= DateValue("10-Oct-22") Then
      ' 执行写入逻辑
  End If
  

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