txt文件导入表中

529905149

请问如何将文件夹中多个txt文本文件用VBA批量导入到excel表格中，谢谢！

liulang0808

Sub test()
    Set fso = CreateObject("scripting.filesystemobject")
    Application.ScreenUpdating = False
   
    xh = 0
    For Each f In fso.getfolder(ThisWorkbook.Path).Files
        If InStr(f.Name, ".txt") > 0 Then
            Open f For Input As #1
            s = StrConv(InputB(LOF(1), 1), vbUnicode)
            brr = Split(s, vbCrLf)
            Close #1
            r = 0
            ReDim arr(1 To UBound(brr) / 6, 1 To 7)
            For j = 0 To UBound(brr)
                If brr(j) = "操作" Then
                    x = j
                    Exit For
                End If
            Next j
            For j = x + 1 To UBound(brr) - 10 Step 7
                r = r + 1
                For i = 1 To 6
                    arr(r, 1 + i) = brr(j + i)
                Next i
                xh = xh + 1
                arr(r, 1) = xh
            Next j
            Cells(Rows.Count, 1).End(3).Offset(1).Resize(r, 7) = arr
            
        End If
    Next
   
    Application.ScreenUpdating = True
End Sub

liulang0808

供参考。。。。。

ykcbf1100

参与一下。。。

ykcbf1100

1. Sub ykcbf()    '//2025.3.14
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     ReDim brr(1 To 1000, 1 To 8)
   
7.     On Error Resume Next
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If LCase$(f.Name) Like "*.txt" Then
   
10.             Open f For Input As #1
    
11.             zrr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
    
12.             Close #1
    
13.             t = t + 1
    
14.             For i = 1 To UBound(zrr)
    
15.                 If InStr(zrr(i), "序号") Then r1 = i
    
16.                 If Left(zrr(i), 1) = "共" Then r2 = i
    
17.             Next
    
18.             If t = 1 Then
    
19.                 m = m + 1
    
20.                 For x = r1 To r1 + 7
    
21.                     k = k + 1
    
22.                     brr(1, k) = zrr(x)
    
23.                 Next
    
24.             Else
    
25.                 For x = r1 + 8 To r2 - 1 Step 7
    
26.                     m = m + 1
    
27.                     For i = 1 To 7
    
28.                         brr(m, i) = zrr(x + i - 1)
    
29.                     Next
    
30.                 Next
    
31.             End If
    
32.         End If
    
33.     Next f
    
34.     With sh
    
35.         .UsedRange.Clear
    
36.         .[a1].Resize(m, 8) = brr
    
37.         .[a1].Resize(m, 8).Borders.LineStyle = 1
    
38.     End With
    
39.     Application.ScreenUpdating = True
    
40.     MsgBox "OK！"
    
41. End Sub
    
42. 
    

复制代码

529905149

liulang0808 发表于 2025-3-14 13:09
Sub test()
    Set fso = CreateObject("scripting.filesystemobject")
    Application.ScreenUpdating ...

老师，谢谢您的解答。怎么加上标题行呢

liulang0808

529905149 发表于 2025-3-14 15:37
老师，谢谢您的解答。怎么加上标题行呢

第一行是事先填写好的标题，如果要通过文本文件内容来添加，找到对应位置提取就可以了

gwjkkkkk

gwjkkkkk

参与一下。。。

chxw68

1. Sub test()
   
2.     Dim r%, i%, x%(1 To 2)
   
3.     Dim arr, brr(1 To 10000, 1 To 7)
   
4.     Dim mypath$, myname$
   
5.     mypath = ThisWorkbook.Path & ""
   
6.     myname = Dir(mypath & "*.txt")
   
7.     m = 0
   
8.     Do While myname <> ""
   
9.         Open mypath & myname For Input As #1
   
10.         arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
    
11.         Close #1
    
12.         Erase x
    
13.         For i = 0 To UBound(arr)
    
14.             If arr(i) = "操作" Then
    
15.                 x(1) = i + 1
    
16.                 Exit For
    
17.             End If
    
18.         Next
    
19.         If m = 0 Then
    
20.             If x(1) <> 0 Then
    
21.                 m = m + 1
    
22.                 For k = 1 To 7
    
23.                     brr(m, k) = arr(x(1) - 8 + k - 1)
    
24.                 Next
    
25.             End If
    
26.         End If
    
27.                     
    
28.         For i = UBound(arr) To 0 Step -1
    
29.             If arr(i) Like "共*条" Then
    
30.                 x(2) = i - 1
    
31.                 Exit For
    
32.             End If
    
33.         Next
    
34.         If x(1) <> 0 And x(2) <> 0 Then
    
35.             For i = x(1) To x(2) Step 7
    
36.                 m = m + 1
    
37.                 For k = 1 To 7
    
38.                     brr(m, k) = arr(i + k - 1)
    
39.                 Next
    
40.             Next
    
41.         End If
    
42.         myname = Dir
    
43.     Loop
    
44.     With Worksheets("sheet1")
    
45.         .Cells.ClearContents
    
46.         .Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
    
47.     End With
    
48. End Sub
    

复制代码