2

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.

Improve this question
12
  • How is data formatted in the file? Is there a column separator? Commented Mar 3, 2021 at 6:50
  • Try s[plitting that line by ". " (period and then a space, that way it'll keep your decimal numbers intact while splitting the line into an array of values for which you can add to your sheet separately) then using nested loops just add the correct values under the correct headings Commented Mar 3, 2021 at 7:03
  • Hi @porkaloca. Sorry. I just update my input text file and there's no column separator Commented Mar 3, 2021 at 7:24
  • Hi @DaMahdi03. Tried before, unfortunately that doesnt work but I believe I may be wrong. I am new in VBA Commented Mar 3, 2021 at 7:34
  • Could you share a link to one of your text files e.g. VSWR W51.txt? Commented Mar 3, 2021 at 7:52

3 Answers 3

Reset to default
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
Improve this answer
Sign up to request clarification or add additional context in comments.

5 Comments

Yes! Perfect!! So awesome. Thanks a lot. Really appreciate! You're the best! You save my life
You're welcome. I have modified the code. I got rid of the horrible labels by using If...ElseIf, a huge mistake (in my opinion). Also, you could improve a little with changing how to write the column labels to the worksheet. See these in CDP1802's solution.
It's a great solution. I have tried writing the code too, but yours is much faster. Compared to your code, I thought about what's wrong with my code.
@Dy Lee: Thanks. It writes every 'Data Block' to an array and copies the array (5707 times) to the worksheet compared to CDP1802's solution which writes each 'Data Line' to an array and then copies the array (125.536 times) to the worksheet. I didn't dare to write the whole thing to an array due to a possible overflow. I've learned a lot from your solutions which are usually beautiful. If you could share your code, I surely would like to take a look.
I got the same result, but I think there were a lot of problems with the approach, but I'm not happy with the processing speed. I think I need to think deeply about how to approach what's wrong with my code.
2

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
Improve this answer

2 Comments

Note that Application.StatusBar = count is 'choking' your code running it 4 minutes longer than necessary. Without it, the code needs 16 seconds for the provided file on my machine. I wonder where you lost the remaining 10 seconds?
Worked like a charm! Thanks a lot CDP1802. Thanks again guyss!
1

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'.

Improve this answer

3 Comments

Application.Trim might be more straightforward and more efficient. Take a look at this.
A good advice. I wasn't aware of this method, as I'm a VB developer, not a VBA guy.
You elegantly took care of it with the 'tools' you knew about. It could easily be modified (become useful) to be used with another character since Application.Trim only covers spaces. I obviously didn't notice your edit.

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.