閱讀文件夾中的所有文件並在Excel中顯示內容

Question

我想顯示文件夾和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 

Answer 1

user1185158

您正在使用會很慢，當你正在閱讀7000個文件的代碼。也沒有代碼可以讀取7000個文件。您將不得不遍歷7000個文件。但是有一個好消息:)你可以將整個文件讀入一個數組，然後將其寫入excel，而不是循環遍歷文本文件中的每一行。例如，看到這個代碼與上面的代碼相比非常快。

嘗試和現在使用循環相同的代碼檢測過

Sub Sample() 
    Dim MyData As String, strData() As String 

    Open "C:\MyFile.Txt" For Binary As #1 
    MyData = Space$(LOF(1)) 
    Get #1, , MyData 
    Close #1 
    strData() = Split(MyData, vbCrLf) 
End Sub 

我們可以把它寫入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個=行線7000

Excel 2003中有65536行和Excel 2007/2010有1048576行。

所以一旦WriteRow達到最大行，你可能需要閱讀文本文件的內容到表2，依此類推......

HTH

希德

Answer 2

以亞洲時報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