需VBA解决方案：从特定格式文本文件提取数据至Excel Sheet1

• 需从特定格式的文本文件中提取指定数据到Excel的Sheet1工作表
• 数据量庞大，无法手动复制整理
• 此前尝试的VBA代码会导入文本文件的全部数据，无法精准提取目标内容

尝试过的无效代码：

Sub CopyDataFromTextFile()
    Dim FilePath As String
    Dim DataPattern As String
    Dim DataArray() As String
    Dim i As Long
    Dim LastRow As Long
    Dim ws As Worksheet
    Dim CopyLine As Boolean
    
    ' Set the file path of the text file
    FilePath = "C:\Users\engr_\Desktop\Data4.txt"
    
    ' Set the data pattern to look for
    DataPattern = "ETHERCAT NETWORK|CAVO ETHERNET CAT6A 10 GBIT RJ45/RJ45|2549850282|1|TO BE ADDED\TO BE REMOVED"
    
    ' Split the data pattern into an array
    DataArray = Split(DataPattern, "|")
    
    ' Set the worksheet to paste the data into
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Change the sheet name as needed
    
    ' Open the text file for reading
    Open FilePath For Input As #1
    
    ' Initialize variables
    LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1
    CopyLine = False
    
    ' Loop through the text file
    Do While Not EOF(1)
        Dim Line As String
        Line Input #1, Line
        ' Check if the line matches the data pattern
        For i = LBound(DataArray) To UBound(DataArray)
            If InStr(1, Line, DataArray(i), vbTextCompare) > 0 Then
                CopyLine = True
                Exit For
            End If
        Next i
        ' If CopyLine is True, copy the line to the worksheet
        If CopyLine Then
            ws.Cells(LastRow, 2).Value = Line
            LastRow = LastRow + 1
        End If
    Loop
    
    ' Close the text file
    Close #1
End Sub

问题分析 #

原代码的核心问题是：一旦CopyLine被设为True后没有重置，导致后续所有行都会被错误导入；同时匹配逻辑仅判断行包含任意关键词，若需更精准匹配（如包含所有关键词）也未实现。

Sub ExtractTargetDataToSheet()
    Dim FilePath As String
    Dim TargetKeywords As Variant
    Dim ws As Worksheet
    Dim LastRow As Long
    Dim Line As String
    Dim isTargetLine As Boolean
    Dim keyword As Variant
    
    ' 设置文本文件路径，根据实际路径修改
    FilePath = "C:\Users\engr_\Desktop\Data4.txt"
    ' 设置需要提取的目标关键词集合
    TargetKeywords = Array("ETHERCAT NETWORK", "CAVO ETHERNET CAT6A 10 GBIT RJ45/RJ45", "2549850282", "1", "TO BE ADDED\TO BE REMOVED")
    ' 指定目标工作表
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ' 获取Sheet1中B列最后一行的下一行
    LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row + 1
    
    ' 打开文本文件读取
    Open FilePath For Input As #1
    
    Do While Not EOF(1)
        Line Input #1, Line
        isTargetLine = False
        
        ' 检查当前行是否包含任意一个目标关键词
        For Each keyword In TargetKeywords
            If InStr(1, Line, keyword, vbTextCompare) > 0 Then
                isTargetLine = True
                Exit For
            End If
        Next keyword
        
        ' 如果是目标行，写入到Sheet1的B列
        If isTargetLine Then
            ws.Cells(LastRow, "B").Value = Line
            LastRow = LastRow + 1
        End If
    Loop
    
    ' 关闭文本文件
    Close #1
    MsgBox "数据提取完成！", vbInformation
End Sub

代码说明 #

1. 重置标记位：每次循环都将isTargetLine重置为False，彻底避免误导入后续行的问题
2. 灵活匹配逻辑：当前逻辑为匹配任意关键词即可提取，若需匹配所有关键词，可替换为以下代码：

' 替换原匹配逻辑为：仅当行包含所有关键词时才标记为目标行
isTargetLine = True
For Each keyword In TargetKeywords
    If InStr(1, Line, keyword, vbTextCompare) = 0 Then
        isTargetLine = False
        Exit For
    End If
Next keyword

3. 易维护性：用数组存储关键词，新增或修改关键词只需修改TargetKeywords数组即可
4. 操作反馈：执行完成后弹出提示框，确认提取操作结束

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