按条件提取文本文件内容写入excel。

mudao

文件夹内有日期等信息为文件名的文本文件若干，
文件名20210220***，
内在数据行（数字数据固定为21位）如：
14:52:05 原始数据：35 39 39 45 20 31 38 32 31 32 31 52 31 31 30 30 31 30 31 36 14
需要将文件名中的日期、数据行的内容按以下格式录入excel内
如:“日期”  “时间”  “8-11位数(每位数据的第一位不要，将剩余数据组合在一起，如上例中的32 31 32 31转换为2121)”        "12位数（52）"        "13-15位数(每位数据的第一位不要，将剩余数据组合在一起，如上例中的31 31 30转换为110)"          "16-17位数(每位数据的第一位不要，将剩余数据组合在一起，如上例中的30 31转换为01"        "18-20位数(每位数据的第一位不要，将剩余数据组合在一起，如上例中的30 31 36转换为016。修订：原写为18-19位，因此造成kzg2013回答问题的语句有些问题，但好在代码很好理解，稍稍更改就好了)"
“20210220 14:52:05 2121 52 110 01 016”
搜索贴子，有高手以前解答问题的代码可以提取数据到excel,但还需要在excel内进行筛选、提取等工作，不是很方便且没多文件提取及日期写入的功能。求助各位大神给写个完善一下，工作急需，谢谢！

                                       

约定的童话

Sub 提取log()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    t = Timer
    On Error Resume Next
    Dim i, n, arr, brr(1 To 1000, 1 To 8)
    F = Dir(ThisWorkbook.Path & "\" & "*.log*")
    Do While F <> ""
        arr = Split(ReadXML(ThisWorkbook.Path & "\" & F), Chr(10))
        For i = 1 To UBound(arr) Step 11
            n = n + 1
            brr(n, 1) = Split(F, "-P")(0)
            brr(n, 2) = Left(arr(i), 8)
            brr(n, 3) = Mid(arr(i), 40, 1) & Mid(arr(i), 43, 1) & Mid(arr(i), 46, 1) & Mid(arr(i), 49, 1)
            brr(n, 4) = Mid(arr(i), 51, 2)
            brr(n, 5) = Mid(arr(i), 55, 1) & Mid(arr(i), 58, 1) & Mid(arr(i), 61, 1)
            brr(n, 6) = Mid(arr(i), 64, 1) & Mid(arr(i), 67, 1)
            brr(n, 7) = Mid(arr(i), 70, 1) & Mid(arr(i), 73, 1) & Mid(arr(i), 76, 1)
        Next
        F = Dir
    Loop
    [A2].Resize(UBound(brr), 8) = brr
    MsgBox "转换完毕！耗时:" & Format(Timer - t, "0.00") & "秒！", , "报告！"
End Sub

mudao

约定的童话 发表于 2021-2-27 23:11
小试牛刀一下。。。

没看到代码。

kzg2013

Sub ExtraTxtData()
Dim fso As Object
Dim reg As Object
Dim fd As Object
Dim rel As Object
Dim r As Long: Dim m As Long
Dim fileName As String: Dim name_txt As String: Dim s As String
  fileName = ActiveWorkbook.Path
  Set fso = CreateObject("scripting.filesystemobject")
  Set reg = CreateObject("vbscript.regexp")
  Set fd = fso.getfolder(fileName)
       For Each fl In fd.Files
           If UCase(fso.GetExtensionName(fl)) = "LOG" Then
               Set tx = fso.opentextfile(fl, 1)
               name_txt = fso.getbasename(fl)
                s = tx.ReadAll
                With reg
                .Pattern = "(b*.+)原始数据+(.+)\n"
                .ignorecase = True
                .Global = True
                Set rel = .Execute(s)
                End With
                If rel.Count > 0 Then
                  For m = 0 To rel.Count - 1
                   r = Cells(Rows.Count, "A").End(xlUp).Row
                   Cells(r + 1, "A") = Application.Substitute(Left(name_txt, 10), "-", "")
                   Cells(r + 1, "b") = rel(m).submatches(0)
                   Range(Cells(r + 1, "c"), Cells(r + 1, "g")) = joinSTR(rel(m).submatches(1))
                  Next m
                End If
           End If
           Set fl = Nothing
       Next

       Set fso = Nothing
       Set fd = Nothing
       Set reg = Nothing
End Sub

Function joinSTR(str As String)
      Dim ar_rel
      Dim ar(4)
     ar_rel = Split(str, " ")
      ar(0) = "'" & Right(ar_rel(7), 1) & Right(ar_rel(8), 1) & Right(ar_rel(9), 1) & Right(ar_rel(10), 1)
      ar(1) = "'" & ar_rel(11)
      ar(2) = "'" & Right(ar_rel(12), 1) & Right(ar_rel(13), 1) & Right(ar_rel(14), 1)
      ar(3) = "'" & Right(ar_rel(15), 1) & Right(ar_rel(16), 1)
      ar(4) = "'" & Right(ar_rel(17), 1) & Right(ar_rel(18), 1)
    joinSTR = ar
End Function

kzg2013

已上传，未审核

准提部林

Sub TEST_A1()
Dim PH$, F$, T$, SR, X$(1 To 5), i&, j%, r&
PH = ThisWorkbook.Path & "\"
Do
   If F = "" Then F = Dir(PH & "2021-??-??-Pic.log") Else F = Dir
   If F = "" Then Exit Do
   Open PH & F For Input Access Read As #1
   Do While Not EOF(1)
         Line Input #1, T
         If Not T Like "*" & Trim(Application.Rept("## ", 21)) & "*" Then GoTo 101
         SR = Split(" " & Right(Trim(T), 62), " ")
         For i = 8 To 20
             j = Application.Match(i, [{8,12,13,16,18}])
             X(j) = X(j) & Right(SR(i), IIf(i = 12, 2, 1))
         Next i
         Cells(r + 1, 1) = Replace(Left(F, 10), "-", "") & " " & Left(T, 8) & " " & Join(X, " ")
         r = r + 1: Erase X()
101: Loop
   Close #1
Loop
End Sub

mudao

kzg2013 发表于 2021-2-28 11:29
已上传，未审核

简单试了一下，功能正常。谢谢！这个是运行速度很快。

mudao

约定的童话 发表于 2021-2-27 23:11
Sub 提取log()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

您的代码很简洁，但我运行时提示ReadXML子过程或者函数未定义。本人白的很，用的是WPS，请教如何解决，谢谢！

约定的童话

mudao 发表于 2021-2-28 13:39
您的代码很简洁，但我运行时提示ReadXML子过程或者函数未定义。本人白的很，用的是WPS，请教如何解决，谢 ...

ReadXML这个百度上的代码，忘记发了，你百度找下凑上去用

mudao

准提部林 发表于 2021-2-28 12:29
Sub TEST_A1()
Dim PH$, F$, T$, SR, X$(1 To 5), i&, j%, r&
PH = ThisWorkbook.Path & "\"

代码正常通过，如果能分列就更好了。谢谢