如何提取多个TXT的指定内容放在EXCEL里

郑同学66

一个TXT里含有多个相同格式的log数据，每行的内容长度不同，要求：提取文件夹的log文件指定内容，求各位大佬指导！！

郑同学66

不要沉 不要沉

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()         '//2024.4.9
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     ReDim brr(1 To 10000, 1 To 5)
   
7.     For Each f In fso.GetFolder(p).Files
   
8.         If LCase(f.Name) Like "*.txt" Then
   
9.             fn = fso.GetBaseName(f)
   
10.             arr = Split(ReadUTFText(f), vbCrLf)
    
11.             For i = 0 To UBound(arr) Step 8
    
12.                 m = m + 1
    
13.                 brr(m, 1) = fn
    
14.                 brr(m, 2) = arr(i)
    
15.                 brr(m, 3) = Replace(Split(arr(i + 4), "=")(1), "Ω", "")
    
16.                 brr(m, 4) = Replace(Split(arr(i + 5), "=")(1), "Ω", "")
    
17.                 brr(m, 5) = Replace(Split(arr(i + 6), "=")(1), "Ω", "")
    
18.             Next
    
19.         End If
    
20.     Next f
    
21.     With sh
    
22.         .UsedRange.Offset(1) = ""
    
23.         .[a2].Resize(m, 5) = brr
    
24.     End With
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "OK！"
    
27. End Sub

复制代码

郑同学66

ykcbf1100 发表于 2024-4-9 16:30
参与一下。。。

大佬，可以加个注释吗，完全看不懂，想学习一下，谢谢大佬

ykcbf1100

郑同学66 发表于 2024-4-9 16:39
大佬，可以加个注释吗，完全看不懂，想学习一下，谢谢大佬

完全看不懂的话加注释也没用啊，你还是先去学习一下VBA的基础知识吧。

gwjkkkkk

Option Explicit
Sub test()
    Dim strFileName$, strPath$, strTxtName$
    Dim ar, i&, r&, strTxt$, aMatch As Object

    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.txt")
    ReDim ar(1 To 10 ^ 3, 4)
   
    With CreateObject("VBScript.RegExp")
        .Pattern = "(x\=.+?y\=.{1}).+?r\=(\d+).+?r\=?(\d+).+?r\=?(\d+)"
        .Global = True
        .IgnoreCase = True
        Do Until strFileName = ""
            strTxt = ReadFromTextFile(ThisWorkbook.Path & "\" & strFileName)
            strTxt = Replace(strTxt, vbCrLf, "")
            strTxtName = Left(strFileName, InStrRev(strFileName, ".") - 1)
            If .test(strTxt) Then
                 For Each aMatch In .Execute(strTxt)
                     r = r + 1
                     For i = 0 To aMatch.submatches.Count - 1
                         ar(r, 0) = strTxtName
                         ar(r, i + 1) = aMatch.submatches(i)
                     Next i
                 Next
            End If
            strFileName = Dir
        Loop
    End With
   
    [A1].CurrentRegion.Offset(1).Clear
    [A2].Resize(r, 5) = ar
    Beep
End Sub
Function ReadFromTextFile$(ByVal strFullName$, Optional ByVal strCharSet$ = "UTF-8")
    With CreateObject("ADODB.Stream")
        .Type = 2
        .Mode = 3
        .Charset = strCharSet
        .Open
        .LoadFromFile strFullName
        ReadFromTextFile = .ReadText
        .Close
    End With
End Function

gwjkkkkk

参与一下。。。

ooluckydog

Sub 提取txt日志内容()
   
    Dim objStream, sItem
    Dim strText As String, i&, j&, k&
    Dim cFiles As New Collection
    Dim regex As Object, matches, match
    Set regex = CreateObject("vbscript.regexp")
   
    With Application.FileDialog(msoFileDialogFilePicker)
        With .Filters
                .Clear
                .Add "txt文件", "*.txt"
        End With
        .AllowMultiSelect = True
        If Not .Show Then Exit Sub
        
        For Each sItem In .SelectedItems
            cFiles.Add sItem
        Next
    End With
   
    Set objStream = CreateObject("ADODB.Stream")
    objStream.Charset = "utf-8"
    objStream.Open
   
    With regex
        .Global = True
        .IgnoreCase = True
        .Pattern = "(x=\d+\Wy=\d+)|(?:R=)(\d+)"
        For i = 1 To cFiles.Count
            objStream.LoadFromFile (cFiles(i))
            strText = objStream.ReadText()
            If .test(strText) Then
                Set matches = .Execute(strText)
                For Each match In matches
                    If j Mod 4 = 0 Then
                        k = k + 1
                        j = 1
                        Cells(k + 1, 2) = cFiles(i)
                        Cells(k + 1, j + 2) = match.SubMatches(0)
                    Else
                        j = j + 1
                        Cells(k + 1, j + 2) = match.SubMatches(1)
                        
                    End If
                Next
            End If
        Next
    End With
   
    objStream.Close
    Set objStream = Nothing
   
End Sub

东山飞鸽

学习了，谢谢高手！