从文本文件复制数据（以从PDF文件中提取的特定模式）

Question

需要将数据从文本文件复制到 Excel Sheet1 的支持。在文本文件中，数据具有特定的模式，并且想要从中提取一些数据以进行Excel处理。所需的结果是手动添加到所附照片中的。还附上文本文件照片以供参考。由于数据量很大，无法手动复制，因此需要 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

Answer 1

文本文件中的数据不是组织良好的表格，因此很难确定如何分割每一行。

注意：：请检查输出中的

TECHNICAL DESCRIPTION

部分，因为它可能需要微调。

Option Explicit

Sub Deomo()
    Dim FilePath As String
    Dim csvWK As Workbook, csvSht As Worksheet
    Dim arrData, arrRes(), sKey
    Dim i As Long, j As Long
    Const KEY1 = "TO BE ADDE"
    Const KEY2 = "TO BE REMO"
    Application.ScreenUpdating = False
    FilePath = "d:\TEMP\Data4.txt" ' Modify as needed
    ' Split by widht
    Workbooks.OpenText Filename:=FilePath, Origin:=xlWindows, _
        StartRow:=1, DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(10, 1), Array(56, 1), _
        Array(100, 1), Array(110, 1), Array(128, 1))
    Set csvWK = ActiveWorkbook
    ' Load data
    With csvWK.ActiveSheet
        arrData = .UsedRange.Value
    End With
    csvWK.Close False
    ReDim arrRes(1 To 5, 1 To UBound(arrData))
    j = 1
    ' Populate header
    For Each sKey In Split("DESCRIPTION|TECHNICAL DESCRIPTION|PARTS CODE|QTY|TO BE ADDED/REMOVED", "|")
        arrRes(j, 1) = sKey
        j = j + 1
    Next sKey
    j = 1
    For i = LBound(arrData) To UBound(arrData)
        sKey = Trim(arrData(i, 4))
        ' Matching keyword
        If sKey = KEY1 Or sKey = KEY2 Then
            j = j + 1
            ' TO BE ADDED/REMOVED
            arrRes(5, j) = sKey & IIf(sKey = KEY1, "D", "VED")
            ' QTY
            arrRes(4, j) = arrData(i - 1, 6)
            ' PARTS CODE
            arrRes(3, j) = "'" & Trim(arrData(i - 1, 5))
            ' TECHNICAL DESCRIPTION
            arrRes(2, j) = arrData(i - 1, 3) & arrData(i - 1, 4)
            ' DESCRIPTION
            arrRes(1, j) = arrData(i, 2)
        End If
    Next i
    ReDim Preserve arrRes(1 To 5, 1 To j)
    ' Write data to work sheet
    With ActiveSheet
        .Cells.Clear
        .Range("A1").Resize(j, 5).Value = Application.Transpose(arrRes)
        .Columns("A:E").AutoFit
    End With
    Application.ScreenUpdating = True
End Sub