excel - 在 vba 中将文本文件中的数据提取到 Excel 中

Question

我需要将文本文件中的数据提取到 Excel 文件中。我曾经问过Vbscript extract data from Text File into Excel

但尝试了几周后仍然没有成功，所以我改用 vba。 这是我所拥有的:

Sub ExtractData()

Dim filename As String, nextrow As Long, MyFolder As String
Dim MyFile As String, text As String, textline As String, filedate As String
Dim filenum As Integer
Dim idx%

MyFolder = "D:\Automation\VSWR\"
MyFile = Dir(MyFolder & "VSWR W51.txt")

nextrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1

Cells(1, 1).Value = "eNodeBName"
Cells(1, 2).Value = "Time"
Cells(1, 3).Value = "MML SN"
Cells(1, 4).Value = "MML Command"
Cells(1, 5).Value = "Retcode"
Cells(1, 6).Value = "Explain_info"
Cells(1, 7).Value = "Cabinet No."
Cells(1, 8).Value = "Subrack No."
Cells(1, 9).Value = "Slot No."
Cells(1, 10).Value = "TX Channel No."
Cells(1, 11).Value = "VSWR(0.01)"
'Columns(1).EntireColumn.AutoFit

Do While MyFile <> ""

Open (MyFolder & MyFile) For Input As #1

    Do Until EOF(1)
        Line Input #1, textline 'read a line
        
        idx = InStr(textline, "NE")
        If idx > 0 Then
            'ActiveSheet.Cells(nextrow, "A").Value = Mid(textline, idx + 5)
            ActiveSheet.Cells(nextrow, "A").Value = Mid(textline, filenum + 5)
        End If

        idx = InStr(textline, "Report")
        If idx > 0 Then
            ActiveSheet.Cells(nextrow, "B").Value = Right(textline, filenum + 19)
        End If
        
        idx = InStr(textline, "O&M")
        If idx > 0 Then
            ActiveSheet.Cells(nextrow, "C").Value = ("O&M" & Mid(textline, filenum + 4))
        End If
        
        
        idx = InStr(textline, "MML Session")
        If idx > 0 Then
            ActiveSheet.Cells(nextrow, "D").Value = "DSP VSWR:;"
        End If
        
        
        idx = InStr(textline, "RETCODE")
        If idx > 0 Then
            ActiveSheet.Cells(nextrow, "E").Value = "0"
        End If
           
        idx = InStr(textline, "RETCODE")
        If idx > 0 Then
            ActiveSheet.Cells(nextrow, "F").Value = Mid(textline, filenum + 12)

            'nextrow = nextrow + 1 'now move to next row
        End If
                 
        idx = InStr(textline, "Cabinet No.")
        If idx > 0 Then
        
            Line Input #1, textline
            Line Input #1, textline
            ActiveSheet.Cells(nextrow, "G").Value = Mid(textline, filenum + 1)
            
            nextrow = nextrow + 1 'now move to next row
        End If
    Loop  
Close #1
MyFile = Dir()

Loop
End Sub

几乎成功，但唯一的问题是我似乎无法弄清楚如何使这一行将数据分成 5 个单独的列。

idx = InStr(textline, "Cabinet No.")
If idx > 0 Then
        
Line Input #1, textline
Line Input #1, textline
ActiveSheet.Cells(nextrow, "G").Value = Mid(textline, filenum + 1)
            
nextrow = nextrow + 1 'now move to next row
End If`

文本文件中的示例输入 Input

我想要的输出应该是这样的 Output

提前致谢，非常感谢。

Answer 1

文本到 Excel

• 请注意，这将为您提供的文件生成超过 125.000 行。确保没有超出 1048576 Excel 行数限制。目前，在我的机器上提供的文件大约需要 6 秒。

代码

Option Explicit

Sub ExtractData()
    
    Const FolderPath = "D:\Automation\VSWR\"
    Const FilePattern As String = "*.txt" ' or rather "VSWR W5*.txt"
    Const dName As String = "Sheet1"
    Const dCol As String = "A"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Application.ScreenUpdating = False
    
    Dim dCell As Range
    With wb.Worksheets(dName)
        ' Write headers.
        .Cells(1, 1).Value = "eNodeBName"
        .Cells(1, 2).Value = "Time"
        .Cells(1, 3).Value = "MML SN"
        .Cells(1, 4).Value = "MML Command"
        .Cells(1, 5).Value = "Retcode"
        .Cells(1, 6).Value = "Explain_info"
        .Cells(1, 7).Value = "Cabinet No."
        .Cells(1, 8).Value = "Subrack No."
        .Cells(1, 9).Value = "Slot No."
        .Cells(1, 10).Value = "TX Channel No."
        .Cells(1, 11).Value = "VSWR(0.01)"
        ' Determine next available cell.
        Set dCell = .Cells(.Rows.count, dCol).End(xlUp).Offset(1)
    End With
    
    Dim FileNum As Long: FileNum = FreeFile
    Dim FileName As String: FileName = Dir(FolderPath & FilePattern)
    Dim RowLabels(6) As Variant
    Dim Data() As Variant
    Dim Result As Variant
    Dim r As Long
    Dim c As Long
    Dim TextLine As String
    
    Do While FileName <> ""
        
        Open (FolderPath & FileName) For Input As FileNum
    
            Do Until EOF(FileNum)
                
                Line Input #FileNum, TextLine 'read a line
                
                If InStr(TextLine, "NE : ") = 1 Then
                    RowLabels(1) = Mid(TextLine, 5)
                ElseIf InStr(TextLine, "Report : +++    ") = 1 Then
                    RowLabels(2) = Right(TextLine, 19)
                ElseIf InStr(TextLine, "O&M    ") = 1 Then
                    RowLabels(3) = ("O&M " & Mid(TextLine, 8))
                ElseIf InStr(TextLine, "MML Session") > 0 Then
                    RowLabels(4) = "DSP VSWR:;"
                ElseIf InStr(TextLine, "RETCODE = ") = 1 Then
                    RowLabels(5) = "0"
                    RowLabels(6) = Mid(TextLine, 12)
                ElseIf InStr(TextLine, "Cabinet No.  Subrack No.  Slot No." _
                    & "  TX Channel No.  VSWR(0.01)") = 1 Then
                    Line Input #FileNum, TextLine
                    c = 0
                    Do
                        Line Input #FileNum, TextLine
                        Select Case True
                        Case InStr(TextLine, "(Number of results = ") = 1
                            Exit Do
                        Case Len(TextLine) = 0
                        Case Else
                            c = c + 1
                            ReDim Preserve Data(7 To 11, 1 To c)
                            Data(7, c) = Trim(Mid(TextLine, 1, 11))
                            Data(8, c) = Trim(Mid(TextLine, 12, 13))
                            Data(9, c) = Trim(Mid(TextLine, 25, 10))
                            Data(10, c) = Trim(Mid(TextLine, 35, 16))
                            Data(11, c) = Trim(Mid(TextLine, 51))
                        End Select
                    Loop
                    ReDim Result(1 To c, 1 To 11)
                    For r = 1 To c
                        For c = 1 To 6
                            Result(r, c) = RowLabels(c)
                        Next c
                        For c = 7 To 11
                            Result(r, c) = Data(c, r)
                        Next c
                    Next r
                    dCell.Resize(r - 1, 11).Value = Result
                    Set dCell = dCell.Offset(r - 1)
                End If
            
            Loop
        
        Close FileNum
        FileName = Dir()
    
    Loop
    
    With dCell.Worksheet
        .UsedRange.EntireColumn.AutoFit
    End With

    Application.ScreenUpdating = True

End Sub