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

Question

我需要将文本文件中的数据提取到 Excel 文件中。 我曾经问过Vbscript 从文本文件中提取数据到 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 应该是这样的 Output

在此先感谢并非常感谢。

Answer 1

使用Application.Trim和Split来分隔列。

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

发短信给 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

Answer 3

有多种方法可以解决这个问题，这是一种使用Split()方法的方法，使用示例文件中的示例行：

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

正如下面@VBasic2008 所建议的那样，在这种目标是删除多个空格的情况下， Application.Trim是更好的解决方案。

由于我的答案可以很容易地适应除空格以外的其他字符，因此我将其保留在此处“原样”。