请教老师，如何批量提取多个txt文件固定位置的内容到excel中

ljfwp

求助各位老师，一个文件夹下有N个txt文件，想提取固定位置的几个数据并罗列到excel里，请问如何用VBA代码实现，谢谢！
注：我搜索了论坛里的类似问题，但是内容一变化我就不知道怎么改了（VBA小白一个，基本不会编写程序）

ljfwp

论坛里有很多类似的帖子，比如http://club.excelhome.net/forum. ... ead&tid=1333817；http://club.excelhome.net/thread-1158304-2-1.html?jdfwkey=ls2o02但是我不会VBA，还请高手帮忙修改下代码，谢谢！
Sub 按钮1_Click()
    Application.ScreenUpdating = False
    a = 2
    For Each f In CreateObject("scripting.filesystemobject").getfolder(ThisWorkbook.Path & "\RawData").Files
        Open f For Input As #1
        While Not EOF(1)
            Line Input #1, str1
            If InStr(str1, ";Logged:") > 0 Then
                Cells(a, 1).Resize(1, 2) = Split(Split(str1, "Logged:")(1), " at ")
            Else
                If Left(str1, 5) = ";Min:" Then
                    Cells(a, 3) = Split(Split(str1, ";Min:")(1), "mJ")(0)
                Else
                    If Left(str1, 5) = ";Max:" Then
                        Cells(a, 4) = Split(Split(str1, ";Max:")(1), "mJ")(0)
                    Else
                        If InStr(str1, ";Average:") > 0 Then
                            Cells(a, 5) = Split(Split(str1, ";Average:")(1), "mJ")(0)
                        Else
                            If InStr(str1, ";Std.Dev.:") > 0 Then
                                Cells(a, 6) = Split(Split(str1, ";Std.Dev.:")(1), "mJ")(0)
                            Else
                                If InStr(str1, ";Overrange:") > 0 Then
                                    Cells(a, 7) = Split(str1, ";Overrange:")(1)
                                Else
                                    If InStr(str1, ";Total Pulses:") > 0 Then
                                        Cells(a, 8) = Split(str1, ";Total Pulses:")(1)
                                        a = a + 1
                                        GoTo l1
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        Wend
l1:
        Close #1
        Next f
    Application.ScreenUpdating = True
End Sub

ww87725244

1. Sub aa()
   
2. Dim d As Object
   
3. Dim d1 As Object, d2 As Object
   
4. Dim ph As String
   
5. Dim sh As Object
   
6. Dim arr(), brr(), crr
   
7. Dim k&, i&, j&, aa, bb, cc
   
8. crr = Array("日期", "当日结存", "风险度")
   
9. Set d = CreateObject("scripting.filesystemobject")
   
10. Set d2 = CreateObject("VBscript.regexp")
    
11. With Application.FileDialog(msoFileDialogFolderPicker)
    
12.     If .Show = True Then
    
13.         ph = .SelectedItems(1)
    
14.         ph = ph & IIf(Right(ph, 1) <> "", "", "")
    
15.     End If
    
16. End With
    
17. With d2
    
18.     .Global = True
    
19.     .Pattern = "\W+\:\d+\.\d+|\W+\:\d+"
    
20. End With
    
21. With d
    
22.     For Each sh In .getfolder(ph).Files
    
23.         If .getextensionname(sh) = "txt" Then
    
24.             i = i + 1
    
25.             Set d1 = .opentextfile(sh)
    
26.             Do While Not d1.atendofstream
    
27.                 k = k + 1
    
28.                 ReDim Preserve arr(1 To k)
    
29.                 arr(k) = d1.readline
    
30.                 aa = Replace(arr(k), " ", "")
    
31.                 Set cc = d2.Execute(aa)
    
32.                 For Each bb In cc
    
33.                     For j = LBound(crr) To UBound(crr)
    
34.                         If Split(bb, ":")(0) = crr(j) Then
    
35.                             ReDim Preserve brr(1 To 3, 1 To i)
    
36.                             If crr(j) = "日期" Then
    
37.                                 brr(1, i) = Format(Split(bb, ":")(1), "0000-00-00")
    
38.                                 
    
39.                             ElseIf crr(j) = "当日结存" Then
    
40.                                 brr(2, i) = Split(bb, ":")(1)
    
41.                             Else
    
42.                                 brr(3, i) = Split(bb, ":")(1) & "%"
    
43.                             End If
    
44.                         End If
    
45.                     Next
    
46.                 Next
    
47.             Loop
    
48.         End If
    
49.     Next
    
50. End With
    
51. Sheet1.Range("a1:c1") = crr
    
52. Sheet1.Range("a2").Resize(UBound(brr, 2), UBound(brr)) = Application.Transpose(brr)
    
53. End Sub

复制代码

ww87725244

ph = ph & IIf(Right(ph, 1) <> "", "", "")改成：ph = ph & IIf(Right(ph, 1) <> "\", "\", "")
代码上传时自动消失了，奇怪

ljfwp

ww87725244 发表于 2018-3-1 14:45

谢谢您的回复！但是我贴到excel里时选择还有txt的文件夹出现错误“运行时错误'424':要求对象”，请再帮忙调试一下，万分感谢！

ljfwp

ww87725244 发表于 2018-3-1 15:11
ph = ph & IIf(Right(ph, 1)  "", "", "")改成：ph = ph & IIf(Right(ph, 1)  "\", "\", "")
代码上传时自 ...

修改后保存，显示“请注意！您的文档的部分内容可能包含文档检查器无法删除的个人信息。”

ww87725244

传个附件给你

ljfwp

ww87725244 发表于 2018-3-1 15:30
传个附件给你

谢谢，太感谢你了！已解决问题！

wmm19890823

新手，自己发帖不太会，可能人太多，没看见我的，请教下个各位大神，这个txt批量导入，想提取固定位置的几个数据并罗列到excel里，请问如何用VBA代码实现，谢谢！

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, pos, filename(), i, j, m
  If Not getfilename(filename, ThisWorkbook.Path, ".txt") Then MsgBox "!": Exit Sub
  pos = Array(0, 12, 8, 10, 15, 17, 19, 25)
  ReDim brr(1 To UBound(filename), 1 To UBound(pos))
  For i = 1 To UBound(filename)
    With CreateObject("ADODB.Stream")
      .Type = 2
      .Mode = 3
      .Open
      .LoadFromFile filename(i)
      .Charset = "UTF-8"
      .Position = 2
      arr = Split(.ReadText, vbNewLine)
      .Close
    End With
    If UBound(arr) >= pos(UBound(pos)) Then
      m = m + 1
      For j = 1 To UBound(pos): brr(m, j) = arr(pos(j)): Next
    End If
  Next
  With [a2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    If m > 0 Then .Resize(m, UBound(brr, 2)) = brr
  End With
End Sub

Function getfilename(filename, pth, mark) As Boolean
  Dim f, n
  If Right(pth, 1) <> "\" Then pth = pth & "\"
  f = Dir(pth & "*.*")
  Do While Len(f) > 0
    If LCase(Right(f, Len(mark))) = LCase(mark) Then
      n = n + 1: ReDim Preserve filename(1 To n)
      filename(n) = pth & f
    End If
    f = Dir
  Loop
  If n > 0 Then getfilename = True
End Function