将文本文件最一行不为空的数据写入EXCEC表格中

零柒一

求老师帮忙写个VBA将文本文件d:\1.txt文件最一行不为空的数据写入EXCEC表格中（附件文本文件中有小要求）

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr(1 To 1000, 1 To 4)
   
4.     Dim reg As New RegExp
   
5.     Dim mypath$, myname$
   
6.     With reg
   
7.         .Global = True
   
8.         .Pattern = "\[([^\]]+)\]"
   
9.     End With
   
10.     mypath = ThisWorkbook.Path & ""
    
11.     myname = "1.txt"
    
12. 
    
13.     If Dir(mypath & myname) = "" Then
    
14.         MsgBox mypath & myname & "不存在！"
    
15.         Exit Sub
    
16.     End If
    
17. 
    
18.     With CreateObject("Adodb.Stream")
    
19.         .Type = 2
    
20.         .Mode = 3
    
21.         .Charset = "UTF-8"
    
22.         .Open
    
23.         .Position = 0
    
24.         .LoadFromFile mypath & myname
    
25.         ss = .ReadText
    
26.         arr = Split(ss, vbCrLf)
    
27.         .Close
    
28.     End With
    
29.     m = 0
    
30.     For i = UBound(arr) To LBound(arr) Step -1
    
31.         If Left(arr(i), 2) = "书名" Then
    
32.             Set mh = reg.Execute(arr(i))
    
33.             If mh.Count > 0 Then
    
34.                 m = m + 1
    
35.                 For j = 0 To mh.Count - 1
    
36.                     brr(m, j + 1) = mh(j).SubMatches(0)
    
37.                 Next
    
38.             End If
    
39.         End If
    
40.     Next
    
41.     With Worksheets("sheet1")
    
42.         .UsedRange.Offset(1, 0).ClearContents
    
43.         .Columns(3).NumberFormatLocal = "@"
    
44.         If m > 0 Then
    
45.             .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
46.         End If
    
47.     End With
    
48. End Sub
    

复制代码

chxw68

详见附件。

飞天篮球猪

ykcbf1100

导入TXT文件最后一行数据

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.11        提取数据
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     p = ThisWorkbook.Path & ""
   
5.     f = p & "1.txt"
   
6.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
7.     zrr = Split(ReadUTFText(f), Chr(13))
   
8.     ReDim brr(1 To 1, 1 To 4)
   
9.     For i = UBound(zrr) To 0 Step -1
   
10.         If zrr(i) <> Empty Then
    
11.             s = Trim(WorksheetFunction.Trim(zrr(i)))
    
12.             s = Replace(Replace(Replace(s, "[", ""), "]", ""), Chr(10), "")
    
13.             b = Split(s)
    
14.             If InStr(b(0), "书名") Then
    
15.                 brr(1, 1) = Replace(b(0), "书名", "")
    
16.                 brr(1, 2) = Replace(b(1), "作者", "")
    
17.                 brr(1, 3) = Replace(b(2), "SS号", "")
    
18.                 brr(1, 4) = b(4)
    
19.                 Exit For
    
20.             End If
    
21.         End If
    
22.     Next
    
23.     With sh
    
24.         .UsedRange.Offset(1).ClearContents
    
25.         .Columns(3).NumberFormatLocal = "@"
    
26.         .[a2].Resize(1, 4) = brr
    
27.     End With
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "OK！"
    
30. End Sub
    
31. 
    
32. Function ReadUTFText(ByVal fn As String) As String
    
33.     With CreateObject("ADODB.Stream")
    
34.         .Type = 2
    
35.         .Mode = 3
    
36.         .Open
    
37.         .LoadFromFile fn
    
38.         .Charset = "UTF-8"
    
39.         .Position = 2
    
40.         ReadUTFText = .ReadText
    
41.         .Close
    
42.     End With
    
43. End Function
    
44. 
    

复制代码

ykcbf1100

换一个写法，改用正则提取数据

ykcbf1100

正则提取

1. Sub ykcbf2()   '//2024.9.11        改用正则提取数据
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set reg = CreateObject("VBScript.Regexp")
   
5.     With reg
   
6.         .Global = 1
   
7.         .Pattern = "\[(.*?)\]"
   
8.     End With
   
9.     p = ThisWorkbook.Path & ""
   
10.     f = p & "1.txt"
    
11.     Set sh = ThisWorkbook.Sheets("Sheet1")
    
12.     zrr = Split(ReadUTFText(f), Chr(13))
    
13.     ReDim brr(1 To 1, 1 To 4)
    
14.     For i = UBound(zrr) To 0 Step -1
    
15.         If InStr(zrr(i), "书名") Then
    
16.             s = zrr(i)
    
17.             If reg.test(s) Then
    
18.                 Set mh = reg.Execute(s)
    
19.                 For Each ma In mh
    
20.                     n = n + 1
    
21.                     brr(1, n) = Trim(ma.SubMatches(0))
    
22.                 Next ma
    
23.             End If
    
24.             Exit For
    
25.         End If
    
26.     Next
    
27.     With sh
    
28.         .UsedRange.Offset(1).ClearContents
    
29.         .Columns(3).NumberFormatLocal = "@"
    
30.         .[a2].Resize(1, 4) = brr
    
31.     End With
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK！"
    
34. End Sub
    
35. 
    
36. Function ReadUTFText(ByVal fn As String) As String
    
37.     With CreateObject("ADODB.Stream")
    
38.         .Type = 2
    
39.         .Mode = 3
    
40.         .Open
    
41.         .LoadFromFile fn
    
42.         .Charset = "UTF-8"
    
43.         .Position = 2
    
44.         ReadUTFText = .ReadText
    
45.         .Close
    
46.     End With
    
47. End Function
    

复制代码

零柒一

再请老师们帮哈忙解哈惑：这个1.txt 默认是ANSI编码格式，用你们的公式需要转换为UTF-8,能不能再修改下加个转换的代码？谢谢  了！！

lss001

零柒一 发表于 2024-9-11 16:51
再请老师们帮哈忙解哈惑：这个1.txt 默认是ANSI编码格式，用你们的公式需要转换为UTF-8,能不能再修改下加个 ...

'使用xml不转码参考

Sub xml提取txt文本()
Dim r%, s, t%, f$, hp As Object, ar, br$()

f = ThisWorkbook.Path & "\1.txt" '指定文件
Set hp = CreateObject("Microsoft.Xmlhttp")
hp.Open "GET", f, False
hp.Send

s = hp.ResponseText
ar = Split(s, vbCrLf)
r = Ubound(ar)
ar = Replace(Replace(ar(r), "[", vbCrLf), "]", vbCrLf)
ar = Split(ar, vbCrLf)
r = Ubound(ar)

[a:d].Clear
[a:d].NumberFormatLocal = "@"
ReDim br(1 To r \ 4, 1 To r \ 2)
For t = 0 To r - 1
    s = (t + 2) Mod 2 + 1
    br(s, Int((t + 2) / 2)) = Trim(ar(t))
Next

Cells(1,1).ReSize(Ubound(br), Ubound(br, 2)) = br
Set hp = Nothing
End Sub