将文本文件中的数据提取到 vba 中的 Excel
Extract data from Text File into Excel in vba
我需要将文本文件中的数据提取到 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
提前致谢，非常感谢。
有多种方法可以解决这个问题，这里使用 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 是更好的解决方案。
由于我的回答可以很容易地适应除空格以外的其他字符，所以我把它留在这里 'as is'。
使用 Application.Trim and 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
发短信给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
我需要将文本文件中的数据提取到 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
提前致谢，非常感谢。
有多种方法可以解决这个问题，这里使用 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 是更好的解决方案。
由于我的回答可以很容易地适应除空格以外的其他字符，所以我把它留在这里 'as is'。
使用 Application.Trim and 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
发短信给Excel
- 请注意，这将为您提供的文件生成超过 125.000 行。确保您没有超过
1048576Excel 行限制。目前，我的机器上提供的文件大约需要 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