txt文件指定内容提取

celexcel2017

cnmlgb9998 发表于 2024-6-27 19:33
借楼练一下PQ。

不规则的数据，确实麻烦

松野

1. Sub ykcbf()   '//2024.6.27　　导入TXT文件数据
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d2 = CreateObject("Scripting.Dictionary")
   
5.     Dim arr, brr(1 To 10000, 1 To 6)
   
6.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
7.     p = ThisWorkbook.Path
   
8.     f = p & "\MML任务结果_DSP RRU_20240626_100149.txt"
   
9.     Set wb = Workbooks.Open(f, 0)
   
10.     With wb.Sheets(1)
    
11.         arr = .UsedRange
    
12.         wb.Close False
    
13.     End With
    
14.    
    
15.     For i = 1 To UBound(arr, 1)
    
16.         If IsError(arr(i, 1)) Then
    
17.             arr(i, 1) = "Error 2029"
    
18.         End If
    
19.     Next
    
20.    
    
21.     'On Error Resume Next
    
22.     For i = 1 To UBound(arr)
    
23.         If InStr(arr(i, 1), "网元 : ") Then k = k + 1: d(k) = i
    
24.     Next
    
25.     For k = 1 To d.Count
    
26.         r1 = d(k)
    
27.         If k = d.Count Then r2 = r Else r2 = d(k + 1) - 1
    
28.         st = Mid(arr(r1, 1), 6)
    
29.         For i = r1 To r2
    
30.             If Left(arr(i, 1), 1) = "0" Or Left(arr(i, 1), 1) = "1" Or Left(arr(i, 1), 1) = "2" Or Left(arr(i, 1), 1) = "3" Then
    
31.                 s = WorksheetFunction.Trim(arr(i, 1))
    
32.                 b = Split(s)
    
33.                 m = m + 1
    
34.                 brr(m, 1) = st
    
35.                 For j = 0 To UBound(b)
    
36.                     brr(m, j + 2) = b(j)
    
37.                 Next
    
38.             ElseIf InStr(arr(i, 1), "结果个数") Then
    
39.                 If Split(Split(arr(i, 1), ")")(0), " ")(2) = 1 Then
    
40.                     m = m + 1
    
41.                     brr(m, 1) = st
    
42.                     brr(m, 2) = Split(WorksheetFunction.Trim(arr(i - 5, 1)), " ")(2)
    
43.                     brr(m, 3) = Split(WorksheetFunction.Trim(arr(i - 4, 1)), " ")(2)
    
44.                     brr(m, 4) = Split(WorksheetFunction.Trim(arr(i - 3, 1)), " ")(2)
    
45.                     brr(m, 5) = Split(WorksheetFunction.Trim(arr(i - 2, 1)), " ")(2)
    
46.                     brr(m, 6) = Split(WorksheetFunction.Trim(arr(i - 1, 1)), " ")(2)
    
47.                     End If
    
48.             End If
    
49.         Next
    
50.     Next
    
51.     With sh
    
52.         .UsedRange.Offset(1).Clear
    
53.         If m > 0 Then
    
54.             .[a1].Resize(1, 6).Interior.Color = 49407
    
55.             With .[a2].Resize(m, 6)
    
56.                 .Value = brr
    
57.                 .Borders.LineStyle = 1
    
58.                 .HorizontalAlignment = xlCenter
    
59.                 .VerticalAlignment = xlCenter
    
60.             End With
    
61.         End If
    
62.     End With
    
63.     Application.ScreenUpdating = True
    
64.     MsgBox "OK！"
    
65. End Sub
    
66. 
    

复制代码

主要对3点进行补充下，感谢高手的帮助

松野

1. Sub ykcbf()   '//2024.6.27　　导入TXT文件数据
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d2 = CreateObject("Scripting.Dictionary")
   
5.     Dim arr, brr(1 To 10000, 1 To 6)
   
6.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
7.     p = ThisWorkbook.Path
   
8.     f = p & "\MML任务结果_DSP RRU_20240626_100149.txt"
   
9.     Set wb = Workbooks.Open(f, 0)
   
10.     With wb.Sheets(1)
    
11.         arr = .UsedRange
    
12.         wb.Close False
    
13.     End With
    
14.    
    
15.     For i = 1 To UBound(arr, 1)
    
16.         If IsError(arr(i, 1)) Then
    
17.             arr(i, 1) = "Error 2029"
    
18.         End If
    
19.     Next
    
20.    
    
21.     'On Error Resume Next
    
22.     For i = 1 To UBound(arr)
    
23.         If InStr(arr(i, 1), "网元 : ") Then k = k + 1: d(k) = i
    
24.     Next
    
25.     For k = 1 To d.Count
    
26.         r1 = d(k)
    
27.         If k = d.Count Then r2 = r Else r2 = d(k + 1) - 1
    
28.         st = Mid(arr(r1, 1), 6)
    
29.         For i = r1 To r2
    
30.             If Left(arr(i, 1), 1) = "0" Or Left(arr(i, 1), 1) = "1" Or Left(arr(i, 1), 1) = "2" Or Left(arr(i, 1), 1) = "3" Then
    
31.                 s = WorksheetFunction.Trim(arr(i, 1))
    
32.                 b = Split(s)
    
33.                 m = m + 1
    
34.                 brr(m, 1) = st
    
35.                 For j = 0 To UBound(b)
    
36.                     brr(m, j + 2) = b(j)
    
37.                 Next
    
38.             ElseIf InStr(arr(i, 1), "结果个数") Then
    
39.                 If Split(Split(arr(i, 1), ")")(0), " ")(2) = 1 Then
    
40.                     m = m + 1
    
41.                     brr(m, 1) = st
    
42.                     brr(m, 2) = Split(WorksheetFunction.Trim(arr(i - 5, 1)), " ")(2)
    
43.                     brr(m, 3) = Split(WorksheetFunction.Trim(arr(i - 4, 1)), " ")(2)
    
44.                     brr(m, 4) = Split(WorksheetFunction.Trim(arr(i - 3, 1)), " ")(2)
    
45.                     brr(m, 5) = Split(WorksheetFunction.Trim(arr(i - 2, 1)), " ")(2)
    
46.                     brr(m, 6) = Split(WorksheetFunction.Trim(arr(i - 1, 1)), " ")(2)
    
47.                     End If
    
48.             End If
    
49.         Next
    
50.     Next
    
51.     With sh
    
52.         .UsedRange.Offset(1).Clear
    
53.         If m > 0 Then
    
54.             .[a1].Resize(1, 6).Interior.Color = 49407
    
55.             With .[a2].Resize(m, 6)
    
56.                 .Value = brr
    
57.                 .Borders.LineStyle = 1
    
58.                 .HorizontalAlignment = xlCenter
    
59.                 .VerticalAlignment = xlCenter
    
60.             End With
    
61.         End If
    
62.     End With
    
63.     Application.ScreenUpdating = True
    
64.     MsgBox "OK！"
    
65. End Sub
    
66. 
    
67. 感谢高手的帮助，有3点我做了修改
    
68. 1、对于查询结果是一条的，做了一下判断
    
69. 2、excel错误数据格式做了处理
    
70. 3、柜号可能不是0的做了处理，我加入了0~3

复制代码

limonet

关键字：[PScustomobject]

limonet

Sub limonet()
    CreateObject("wscript.shell").Run "powershell push-location " & ThisWorkbook.Path _
    & ";get-content 系统查询结果.txt -raw | Select-String '网元 :.*\n(.*\n){3}.*执行成功.\n(.*\n){2,32}\(结果个数 = \d+\)' -AllMatches |" _
    & "% { $_.Matches } | % {foreach ($i in $s=($_.Value -split '\n')) { if ($i -match '.*Null') {$ii=($i -replace '\s{2,}',' ');" _
    & "[PSCustomObject]@{网元=($s[0] -split ' : ')[1];柜号=$ii.split()[0];框号=$ii.split()[1];槽号=$ii.split()[2];" _
    & "接入方向=$ii.split()[3];维护链路工作模式=$ii.split()[4]}}}} | export-csv 系统查询结果.csv -NoTypeInformation -encoding default", 0
End Sub

ykcbf1100

松野 发表于 2024-6-28 11:31
完美解决，为啥我最多只能填2分

你级别不够。

onthetrip

最近在学正则，练练手。提取出来的数据多两行空行，不知道什么原因，而且速度有点慢。

1. Option Explicit
   
2. Private Const nMaxItems As Long = 30 '每个条目最多数目,假设数据
   
3. Private Sub ExtraDataFromTxt()
   
4. Dim sFileName$, strText$, sPattern$, oReg As Object
   
5. Dim oMatches As Object, oMatch As Object
   
6. Dim arrTitle(), arrResult(), arrItem
   
7. Dim nItems& '网元个数
   
8. Dim nEachItem& '每个网元的条目数
   
9. Dim strName$, strInfo$
   
10. Dim oMatchData As Object '每个数据记录
    
11. Dim nCount&, i&, j&
    
12. arrTitle = Array("网元名称", "柜号", "框号", "槽号", "接入方向", "维护链路工作模式")
    
13. sFileName = ThisWorkbook.Path & "\系统查询结果.txt"
    
14. strText = ReadFile(sFileName, "GB2312")
    
15. sPattern = "网元 : (.*\n)(?:.*\n)+?柜号.+?\n\r\n((.+\n)+?)\(结果个数"
    
16. Set oReg = CreateObject("vbscript.regexp")
    
17. With oReg
    
18.     .Global = True
    
19.     .Pattern = sPattern
    
20.     Set oMatches = .Execute(strText)
    
21.     nItems = oMatches.Count
    
22. End With
    
23. ReDim arrResult(1 To nItems * nMaxItems, 1 To 6)
    
24. nCount = 0
    
25. For Each oMatch In oMatches
    
26.    strName = oMatch.submatches(0) '网元名称
    
27.    strInfo = oMatch.submatches(1) '一个网元数据记录信息字符串
    
28.    'Erase arrItem
    
29.    arrItem = Split(strInfo, vbLf) '一个网元数据记录数组
    
30.    With oReg
    
31.         .Pattern = "(\S+)\s"
    
32.         For i = LBound(arrItem) To UBound(arrItem) - 1 '一个网元的数据记录写入结果数组。此处-1，是因为多两行空数据，找不到多两行数据的原因
    
33.             nCount = nCount + 1
    
34.             arrResult(nCount, 1) = strName
    
35.             j = 1 '重置列号
    
36.             For Each oMatchData In .Execute(arrItem(i)) '一行的数据记录写入数组
    
37.                 j = j + 1
    
38.                 arrResult(nCount, j) = oMatchData.submatches(0)
    
39.             Next
    
40.         Next
    
41.     End With
    
42. Next
    
43. Cells.ClearContents
    
44. [a1].Resize(1, 6) = arrTitle
    
45. [a2].Resize(nCount, 6) = arrResult
    
46. Set oReg = Nothing
    
47. End Sub
    
48. Function ReadFile(ByVal filename As String, Optional filetype As String = "utf-8")
    
49.     Dim ReadStream As Object
    
50.     Set ReadStream = CreateObject("ADODB.Stream")
    
51.     Dim FileContent As String
    
52.     With ReadStream
    
53.         .Type = 2                                              'adTypeText
    
54.         .Charset = filetype
    
55.         .Open
    
56.         .LoadFromFile filename
    
57.         FileContent = .ReadText
    
58.         .Close
    
59.     End With
    
60.     ReadFile = FileContent
    
61. End Function
    

复制代码