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.

JRashid
  • 23
  • 1
  • 6
  • How is data formatted in the file? Is there a column separator? – DT1 Mar 03 '21 at 06: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 – Da Mahdi03 Mar 03 '21 at 07:03
  • Hi @porkaloca. Sorry. I just update my input text file and there's no column separator – JRashid Mar 03 '21 at 07:24
  • Hi @DaMahdi03. Tried before, unfortunately that doesnt work but I believe I may be wrong. I am new in VBA – JRashid Mar 03 '21 at 07:34
  • Could you share a link to one of your text files e.g. `VSWR W51.txt`? – VBasic2008 Mar 03 '21 at 07:52
  • Hi @VBasic2008 I hope u accept this one https://drive.google.com/file/d/1u8CIQc5UTfcyzD2XvezqYJybp2EDTihC/view?usp=sharing – JRashid Mar 03 '21 at 08:26
  • Your permission is needed to view (download) your file. To remedy this, in the `Google Drive` folder you can right-click the file and select `Share`. Then at the bottom, you can choose to allow something like *with anyone who has the link*. It'll be the same link, no need to modify it. – VBasic2008 Mar 03 '21 at 08:31
  • `Mid` function has one more parameter: the lenght of string to be extracted. Count the position and length of the fields and supply the desired length (width) of the data. For numeric values I suggest using `Val`. `Filenum` is not initialized (but is not really necessary for this conversion). I suggest not to use `Activesheet`, look around here on SO how to avoid using it. So "my code" would look somehow like this: `sh.Cells(nextrow, "A").Value = Val(Mid(textline, 5, 3))` – AcsErno Mar 03 '21 at 08:33
  • Ok just updated @VBasic2008 . Sorry my bad. Thank you so much – JRashid Mar 03 '21 at 08:41
  • Hi @AcsErno Its ok. Feel free to edit my code in your own way. I believe you have a better solution. It's been a few weeks since I got stuck and almost gave up. – JRashid Mar 03 '21 at 08:49
  • @Jrashid You have almost finished. Just count the characters in your input file, like "Subrack no." field begins on position 10 and it is 12 chars wide, so modify the respective line to `sh.Cells(nextrow, "B").Value = Val(Mid(textline, 10, 12))`. – AcsErno Mar 03 '21 at 08:57
  • @AcsErno just tried and that's great! But my desired output is like this https://i.stack.imgur.com/r4sAD.png Meaning all lines from the input need to be print to output – JRashid Mar 03 '21 at 09:28

3 Answers3

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
CDP1802
  • 13,871
  • 2
  • 7
  • 17
  • 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? – VBasic2008 Mar 03 '21 at 12:10
  • Worked like a charm! Thanks a lot CDP1802. Thanks again guyss! – JRashid Mar 03 '21 at 14:46
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
VBasic2008
  • 44,888
  • 5
  • 17
  • 28
  • Yes! Perfect!! So awesome. Thanks a lot. Really appreciate! You're the best! You save my life – JRashid Mar 03 '21 at 12:16
  • 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. – VBasic2008 Mar 03 '21 at 12:34
  • 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 Mar 03 '21 at 15:12
  • @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. – VBasic2008 Mar 03 '21 at 15:32
  • 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. – Dy.Lee Mar 03 '21 at 15:39
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'.

Hel O'Ween
  • 1,423
  • 9
  • 15
  • 3
    `Application.Trim` might be more straightforward and more efficient. Take a look at [this](https://stackoverflow.com/questions/30768072/faster-way-to-remove-extra-spaces-more-than-1-from-a-large-range-of-cells-us/58454080#58454080). – VBasic2008 Mar 03 '21 at 10:17
  • A good advice. I wasn't aware of this method, as I'm a VB developer, not a VBA guy. – Hel O'Ween Mar 04 '21 at 11:52
  • 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. – VBasic2008 Mar 04 '21 at 12:02