将文本文件批量导入到表格文件中

yangfx16900

问题：如何将多个txt文本文件用VBA批量导入到excel表格的A列中，谢谢！

小凡、、、

ykcbf1100

批量导入TXT文件　

ykcbf1100

导入TXT文件

1. Sub ykcbf()   '//2024.11.14
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     sh.UsedRange.ClearContents
   
7.     p = ThisWorkbook.Path & ""
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If LCase$(f.Name) Like "*.txt" Then
   
10.             n = n + 1
    
11.             Set txtFile = fso.OpenTextFile(f, 1, False)
    
12.             zrr = Application.Transpose(Split(txtFile.ReadAll, vbLf))
    
13.             txtFile.Close
    
14.             If n = 1 Then r = 1 Else r = sh.Cells(Rows.Count, 1).End(3).Row + 1
    
15.             sh.Cells(r, 1).Resize(UBound(zrr), 1) = zrr
    
16.         End If
    
17.     Next f
    
18.     Application.ScreenUpdating = True
    
19.     MsgBox "OK！"
    
20. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, y&, x&, r&, n As Byte, strFileName$, strPath$
   
    Application.ScreenUpdating = False
   
    ReDim br(1 To 10 ^ 4, 0)
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.txt")
   
    Do Until strFileName = ""
        n = FreeFile
        Open strPath & strFileName For Input As #n
            ar = Split(StrConv(InputB(LOF(n), #n), vbUnicode), vbCrLf)
        Close #n
        For y = 0 To UBound(ar)
            If Len(ar(y)) Then
                r = r + 1
                br(r, 0) = ar(y)
            End If
        Next y
        strFileName = Dir
    Loop
   
    Columns(1).Clear
    [A1].Resize(r) = br
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。

沧海一粟123123

Sub test()
Dim fu(1 To 10)
Dim k, x, m As Integer
Dim f, filename As String
Dim f1, sr As String

Range("a:a") = ""
f = ThisWorkbook.Path & "\"
filename = Dir(f, vbDirectory)
Do
    If filename Like "*.txt" Then
        k = k + 1
        fu(k) = filename
    End If
    filename = Dir
Loop Until filename = ""

For x = 1 To UBound(fu)
    If fu(x) <> "" Then
        f1 = ThisWorkbook.Path & "\" & fu(x)
        Open f1 For Input As #1
        Do While Not EOF(1)
            Line Input #1, sr
            m = m + 1
            Range("a" & m) = sr
        Loop
        Close #1
    End If
Next x
End Sub

沧海一粟123123

发重复了