文本文档导入

夏日生花

请老师用VBA,指导文本文档导入，谢谢！

baofa2

1. Sub test1() '不严谨，更正一下
   
2.   Application.ScreenUpdating = False
   
3.   Dim results(1 To 50000, 1 To 50) As String, ar, br
   
4.   Dim i As Long, j As Long, k As Long, cnt As Long, col As Long, wks As Worksheet
   
5.   Dim strPath As String, strFile As String, strText As String, strName As String
   
6.   strPath = ThisWorkbook.Path & "\"
   
7.   strFile = Dir(strPath & "*.txt")
   
8.   While Len(strFile)
   
9.     k = k + 1
   
10.     strFile = Dir
    
11.   Wend
    
12.   On Error Resume Next
    
13.   strFile = Dir(strPath & "*.txt")
    
14.   While Len(strFile)
    
15.     strText = Replace(ReadFromTextFile(strPath & strFile, "UTF-8"), Chr(32), vbNullString)
    
16.     ar = Split(strText, vbLf)
    
17.     cnt = 0
    
18.     col = 0
    
19.     For i = 0 To UBound(ar)
    
20.       If Len(ar(i)) Then
    
21.         cnt = cnt + 1
    
22.         br = Split(ar(i), vbTab)
    
23.         For j = 0 To UBound(br)
    
24.           results(cnt, j + 1) = br(j)
    
25.         Next
    
26.         If j > col Then col = j   '据数据这个不能少
    
27.       End If
    
28.     Next
    
29.     If k = 1 Then strName = "导入文本" Else strName = Split(strFile, ".txt")(0)
    
30.     Set wks = Worksheets(strName)
    
31.     If Err.Number Then
    
32.       Err.Clear
    
33.       Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = strName
    
34.     End If
    
35.     With Worksheets(strName)
    
36.       .Cells.Clear
    
37.       .Range("A1").Resize(cnt, col) = results
    
38.     End With
    
39.     Erase results     '据数据这个不能少
    
40.     strFile = Dir
    
41.   Wend
    
42.   Set wks = Nothing
    
43.   Application.ScreenUpdating = True
    
44.   Beep
    
45. End Sub
    
46. 
    
47. Function ReadFromTextFile(ByVal strFullName As String, Optional ByVal strCharSet As String = "UTF-8") As String
    
48.   With CreateObject("ADODB.Stream")
    
49.     .Type = 2
    
50.     .Mode = 3
    
51.     .Charset = strCharSet
    
52.     .Open
    
53.     .LoadFromFile strFullName
    
54.     ReadFromTextFile = .ReadText
    
55.     .Close
    
56.   End With
    
57. End Function
    

复制代码

夏日生花

baofa2 发表于 2024-5-9 14:14

这么长，太谢谢了，辛苦了。

wang-way

baofa2 发表于 2024-5-9 14:14

代码书写的真规范

limonet

关键字：ReadAll

limonet

Sub Limonet()
    Dim WshShell As Object, Arr As Variant, i%, k%, Brr As Variant
    Set WshShell = CreateObject("WScript.Shell")
    WshShell.currentdirectory = ThisWorkbook.Path
    Arr = Split(WshShell.Exec("Powershell get-childitem -file *.txt -name").StdOut.ReadAll, Chr(13) & Chr(10))
    For i = 0 To UBound(Arr) - 1
        If UBound(Arr) > 1 Then Worksheets.Add(after:=Sheets(Sheets.Count)).Name = Split(Arr(i), ".txt")(0)
        Brr = Split(WshShell.Exec("Powershell get-content " & Arr(i)).StdOut.ReadAll, Chr(13) & Chr(10))
        For k = 0 To UBound(Brr) - 1
            Cells(k + 1, "A").Resize(1, UBound(Split(Brr(k), vbTab)) + 1) = Split(Brr(k), vbTab)
        Next k
    Next i
End Sub

gwjkkkkk

baofa2 发表于 2024-5-9 14:14

baofa2兄代码真漂亮，又学到了。。。

baofa2

gwjkkkkk 发表于 2024-5-9 22:42
baofa2兄代码真漂亮，又学到了。。。

你这一说，我又检查了一下，发现几处不严谨的地方，惭愧，还是浮躁

gwjkkkkk

baofa2 发表于 2024-5-10 07:22
你这一说，我又检查了一下，发现几处不严谨的地方，惭愧，还是浮躁

看你的代码，很有收获

feilanga

baofa2 发表于 2024-5-9 14:14

strPath = ThisWorkbook.Path & "\"