从文本文件中提取数据到 vba 中的 Excel

Question

I need to extract data from text file into Excel file. I once asked at Vbscript extract data from Text File into Excel

But after trying for few weeks and still no success so I use vba instead. Here what i have:

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

Almost successful but the only problem is i can't seem to figure out how to make this line split the data into 5 separate columns.

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`

Sample input in text file Input

And my desired output should be like this Output

Thanks in advance and really appreciate.

Answer 1

Using Application.Trim and Split to separate the columns.

Option Explicit

Sub ExtractData()

    Dim wb As Workbook, ws As Worksheet
    Dim MyFile As String, MyFolder As String
    Dim textline As String, ar As Variant
    Dim i As Long, n As Long, count As Long
    Dim arOut(10) As String, t0 As Single
    t0 = Timer
  
    MyFolder = "D:\Automation\VSWR\"
    MyFile = Dir(MyFolder & "VSWR W51.txt")
    
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1)
    ws.Cells.Clear

    i = ws.Cells(Rows.count, "A").End(xlUp).Row + 1
    
    ws.Range("A1:K1") = Array("eNodeBName", "Time", "MML SN", "MML Command", "Retcode", _
                        "Explain_info", "Cabinet No.", "Subrack No.", "Slot No.", _
                        "TX Channel No.", "VSWR(0.01)")
           
    Open (MyFolder & MyFile) For Input As #1
    
    Do Until EOF(1)
            If count Mod 10000 = 0 Then Application.StatusBar = count
            Line Input #1, textline: count = count + 1

            If InStr(textline, "---    END") > 0 Then
                Erase arOut ' clear array

            ElseIf InStr(textline, "NE") > 0 Then
                arOut(0) = Mid(textline, 5)
            
            ElseIf InStr(textline, "Report") > 0 Then
                arOut(1) = Right(textline, 19)
            
            ElseIf InStr(textline, "O&M") > 0 Then
                arOut(2) = "O&M" & Mid(textline, 4)
            
            ElseIf InStr(textline, "MML Session") > 0 Then
                arOut(3) = "DSP VSWR:;"
            
            ElseIf InStr(textline, "RETCODE") > 0 Then
                arOut(4) = Mid(textline, 11, 1)
                arOut(5) = Mid(textline, 12)
            
            ElseIf InStr(textline, "Cabinet No.") > 0 Then
                Line Input #1, textline: count = count + 1
                Line Input #1, textline: count = count + 1
                
                Do While Left(textline, 7) <> "(Number"
                     
                      textline = Application.Trim(textline)
                      ar = Split(textline, " ")
                      'Debug.Print count, textline, UBound(ar)

                      For n = 0 To 4
                          arOut(6 + n) = ar(n)
                      Next
                      ws.Range("A" & i & ":K" & i).Value = arOut
                      i = i + 1 ' now move to next row

                      Line Input #1, textline: count = count + 1
                Loop

            End If
        Loop
    Close #1
    MsgBox Format(count, "#,##0") & " rows read", vbInformation, Int(Timer - t0) & " seconds"
    
End Sub

Answer 2

Text to Excel

• Note that this will generate over 125.000 lines for the file you provided. Make sure you don't exceed the 1048576 Excel rows limit. Currently, it takes about 6 seconds for the file provided on my machine.

The Code

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

Answer 3

There are multiple ways to approach this, here's one using the Split() method, using a sample line from your example file:

Dim s As String
s = "0            60           0         0               108"
' Reduce delimiting spaces to 1
s = RemoveMultipleSpaces(s)

' Split the string into an array
Dim avnt As Variant
avnt = Split(s, " ")

Dim i As Long

For i = LBound(avnt) To UBound(avnt)
   Debug.Print "i: " & CStr(i); ", Value: " & avnt(i); ", Len: " & Len(avnt(i))
Next

' Results in:
' i: 0, Value: 0, Len: 1
' i: 1, Value: 60, Len: 2
' i: 2, Value: 0, Len: 1
' i: 3, Value: 0, Len: 1
' i: 4, Value: 108, Len: 3

' ---

Function RemoveMultipleSpaces(ByVal sSource As String) As String
   ' Remove all occurances of more than 1 space from a string
   Do While InStr(sSource, "  ") > 0
      sSource = Replace(sSource, "  ", " ")
   Loop
   
   RemoveMultipleSpaces = sSource

End Function

As suggested by @VBasic2008 below, in this case where the goal is to remove multiple spaces , Application.Trim is the better solution.

As my answer can be easily adapted to suit other characters than spaces, I leave it here 'as is'.