Vba 读取文件夹中的所有文件并在Excel中显示内容

我想显示文件夹和excel中的7000个文件内容

我发现了一段帮助我的代码，但它只是一个接一个地阅读。然而，我想一次读完7000本书。请帮忙

 Option Explicit
 Sub Import_TXT_File()
 Dim strg As Variant
 Dim EntireLine As String
 Dim FName As String
 Dim i As String

 Application.ScreenUpdating = False
 FName = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "Choose File to Import")
 Open FName For Input Access Read As #1
 i = 1
 While Not EOF(1)
 Line Input #1, EntireLine
 strg = EntireLine
 'Change "Sheet1" to relevant Sheet Name
 'Change "A" to the relevant Column Name
 Sheets("Sheet1").Range("A" & i).Value = strg
 i = i + 1
 Wend
 EndMacro:
 On Error GoTo 0
 Application.ScreenUpdating = True
 Close #1
 End Sub

用户1185158

当您读取7000个文件时，您使用的代码将非常慢。此外，也没有代码可以读取7000个文件在一次去。您必须循环浏览7000个文件。但是有一个好消息：您可以将整个文件读入数组，然后将其写入excel，而不是遍历文本文件中的每一行。例如，看看这段代码，它与上面的代码相比非常快

久经考验

现在，在循环中使用相同的代码，我们可以将其写入Excel文件

'~~> Change this to the relevant path
Const strPath As String = "C:\Temp\"

Sub Sample()
    Dim ws As Worksheet
    Dim MyData As String, strData() As String
    Dim WriteToRow As Long, i As Long
    Dim strCurrentTxtFile As String

    Set ws = Sheets("Sheet1")

    '~~> Start from Row 1
    WriteToRow = 1

    strCurrentTxtFile = Dir(strPath & "*.Txt")

    '~~> Looping through all text files in a folder
    Do While strCurrentTxtFile <> ""

        '~~> Open the file in 1 go to read it into an array
        Open strPath & strCurrentTxtFile For Binary As #1
        MyData = Space$(LOF(1))
        Get #1, , MyData
        Close #1

        strData() = Split(MyData, vbCrLf)

        '~~> Read from the array and write to Excel            
        For i = LBound(strData) To UBound(strData)
            ws.Range("A" & WriteToRow).Value = strData(i)
            WriteToRow = WriteToRow + 1
        Next i

        strCurrentTxtFile = Dir
    Loop

    MsgBox "Done"
End Sub

上面的代码所做的是读取表1中7000个文本文件的内容，一个接一个。此外，我还没有包括错误处理。请这样做

注意：如果您正在阅读重文本文件，例如，每个文件有10000行，那么您将不得不在上述场景中调整代码，因为您将得到错误。比如说

7000个文件*10000行=7000000行

Excel 2003有65536行，Excel 2007/2010有1048576行

因此，一旦WriteRow达到最大行数，您可能希望将文本文件内容读入第2页，以此类推

嗯

---

Sid将Siddharth的解决方案再进一步。您可能不想一次只写一行，Excel中对工作表的调用非常慢，最好在内存中执行任何循环，然后一次写回：

Sub Sample()
    Dim ws As Worksheet
    Dim MyData As String, strData() As String, strData2() As String
    Dim WriteToRow As Long, i As Long
    Dim strCurrentTxtFile As String

    Set ws = Sheets("Sheet1")

    '~~> Start from Row 1
    WriteToRow = 1

    strCurrentTxtFile = Dir(strPath & "*.Txt")

    '~~> Looping through all text files in a folder
    Do While strCurrentTxtFile <> ""

        '~~> Open the file in 1 go to read it into an array
        Open strPath & strCurrentTxtFile For Binary As #1
        MyData = Space$(LOF(1))
        Get #1, , MyData
        Close #1

        strData = Split(MyData, vbCrLf)

        'Resize and transpose 1d array to 2d
        ReDim strData2(1 To UBound(strData) + 1, 1 To 1)
        For i = 1 To UBound(strData)
            strData2(i, 1) = strData(i - 1)
        Next i

        Sheet1.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Offset(1).Resize(UBound(strData), 1).Value = strData2

        strCurrentTxtFile = Dir
    Loop

    MsgBox "Done"
End Sub

---

你应该读一读。@Siddharth Rout。有没有一种方法可以在没有拆分的情况下使用此方法？我的数据是真实的文本，不必要的拆分会将每个单词拆分成字母，如果像我假设的那样导出到excel，将创建大量的列。我尝试在31个txt文件上运行your和@Kyle的代码组合，每个文件平均36行，但任何事情都需要10分钟以上的时间消息完成后在纳秒内出现。。。一定是出什么事了？？？

Sub Sample()
    Dim ws As Worksheet
    Dim MyData As String, strData() As String, strData2() As String
    Dim WriteToRow As Long, i As Long
    Dim strCurrentTxtFile As String

    Set ws = Sheets("Sheet1")

    '~~> Start from Row 1
    WriteToRow = 1

    strCurrentTxtFile = Dir(strPath & "*.Txt")

    '~~> Looping through all text files in a folder
    Do While strCurrentTxtFile <> ""

        '~~> Open the file in 1 go to read it into an array
        Open strPath & strCurrentTxtFile For Binary As #1
        MyData = Space$(LOF(1))
        Get #1, , MyData
        Close #1

        strData = Split(MyData, vbCrLf)

        'Resize and transpose 1d array to 2d
        ReDim strData2(1 To UBound(strData) + 1, 1 To 1)
        For i = 1 To UBound(strData)
            strData2(i, 1) = strData(i - 1)
        Next i

        Sheet1.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Offset(1).Resize(UBound(strData), 1).Value = strData2

        strCurrentTxtFile = Dir
    Loop

    MsgBox "Done"
End Sub