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

ykcbf1100

参与一下。。。

1. Sub ykcbf()         '//2024.4.11
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     ReDim brr(1 To 100000, 1 To 1)
   
8.     On Error Resume Next
   
9.     For Each f In fso.GetFolder(p).Files
   
10.         If LCase(f.Name) Like "*.txt" Then
    
11.             fn = fso.GetBaseName(f)
    
12.             Set wb = Workbooks.Open(f, 0)
    
13.             n = 0
    
14.             d.RemoveAll
    
15.             arr = wb.Sheets(1).UsedRange
    
16.             r = UBound(arr)
    
17.             wb.Close 0
    
18.             For i = 7 To UBound(arr)
    
19.                 If InStr(arr(i, 1), "R10X") Then n = n + 1
    
20.                 d(n) = i + 1
    
21.             Next
    
22.             t = d.items
    
23.             For k = 0 To d.Count
    
24.                 r1 = d(k)
    
25.                 If k = d.Count Then r2 = r Else r2 = d(k + 1) - 1
    
26.                 m = m + 1
    
27.                 brr(m, 1) = arr(r1, 1)
    
28.                 For x = r1 + 1 To r2
    
29.                     If InStr(arr(x, 1), "R=") Then
    
30.                         m = m + 1
    
31.                         brr(m, 1) = arr(x, 1)
    
32.                     End If
    
33.                 Next
    
34.             Next
    
35.         End If
    
36.     Next f
    
37.     With sh
    
38.         .UsedRange.Offset(1) = ""
    
39.         .[a2].Resize(m, 1) = brr
    
40.     End With
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    
44. 
    
45. 
    

复制代码

郑同学66

ykcbf1100 发表于 2024-4-11 10:51
附件供参考。。。

大佬，想要实现这样的要求，望解答，谢谢

baofa2

1. 'WPS 要安装 AccessDatabaseEngine.exe   下载地址 https://www.onlinedown.net/soft/1180584.htm
   
2. 
   
3. Sub test1()
   
4.   Dim ar(1 To 200, 1 To 1000), br, Conn As Object, Flag As Boolean
   
5.   Dim strPath As String, strFile As String, SQL As String
   
6.   Dim i As Long, j As Long, k As Long
   
7.   Dim rowSize As Long, colSize As Long
   
8.   
   
9.   Cells.ClearContents
   
10. Application.ScreenUpdating = False
    
11.   
    
12.   strPath = ThisWorkbook.Path & "\"
    
13.   Set Conn = CreateObject("ADODB.Connection")
    
14.   'Conn.Open "Provider = Microsoft.ACE.OLEDB.12.0;Extended Properties='text;HDR=NO;FMT=Delimited;CharacterSet=65001';Data Source=" & strPath
    
15.   With Conn
    
16.     If Application.Version < 12 Or InStr(Application.Path, "WPS") > 0 Then
    
17.       .Provider = "Microsoft.Jet.OLEDB.4.0"
    
18.     Else
    
19.       .Provider = "Microsoft.ACE.OLEDB.12.0"
    
20.     End If
    
21.     .ConnectionString = "Data Source=" & strPath & ";Extended Properties='text;HDR=NO;FMT=CSVDelimited;CharacterSet=65001';"
    
22.     .Open
    
23.   End With
    
24.   
    
25.   rowSize = 1
    
26.   ar(rowSize, 1) = "LOG名称"
    
27.   ar(rowSize, 2) = "坐标"
    
28.   For j = 3 To UBound(ar, 2)
    
29.     ar(rowSize, j) = "R" & j - 2
    
30.   Next
    
31.   
    
32.   strFile = Dir(strPath & "*.txt")
    
33.   
    
34.   Do
    
35.     SQL = "SELECT * FROM [" & strFile & "] WHERE F1 LIKE '%，x=%BIN=%y=%' OR F1 LIKE '%R%ohm'"
    
36.     br = Conn.Execute(SQL).GetRows
    
37.     For j = 0 To UBound(br, 2)
    
38.       If br(0, j) Like "*，x=*BIN=*y=*" Then
    
39.         Flag = False
    
40.         rowSize = rowSize + 1
    
41.         ar(rowSize, 1) = Split(strFile, ".txt")(0)
    
42.         ar(rowSize, 2) = Mid(br(0, j), InStr(br(0, j), "，") + 1)
    
43.       End If
    
44.       If br(0, j) Like "R10X=*ohm" Then
    
45.         Flag = True
    
46.         j = j + 1
    
47.         k = 2
    
48.       End If
    
49.       If Flag Then
    
50.         If br(0, j) Like "R=*ohm" Then
    
51.           k = k + 1
    
52.           ar(rowSize, k) = Split(Split(br(0, j), "=")(1), Chr(32))(0)
    
53.         End If
    
54.         If k > colSize Then colSize = k
    
55.       End If
    
56.     Next
    
57.     strFile = Dir
    
58.   Loop While Len(strFile)
    
59.   
    
60.   Range("A1").Resize(rowSize, colSize) = ar
    
61.   
    
62.   Conn.Close
    
63.   Set Conn = Nothing
    
64.   Application.ScreenUpdating = True
    
65.   Beep
    
66. End Sub

复制代码

测试.zip (29.49 KB, 下载次数: 2)

2024-4-11 12:26 上传

点击文件名下载附件

郑同学66

郑同学66 发表于 2024-4-11 09:36
大佬，请问一下为什么在运行大数据的时候这个会显示错误，还有在单运行横排的时候只显示一行（应该显示一 ...

我调试了一下，可以实现我想要的功能了，感谢大佬们的耐心指教！！