Reading all files in Folder and showing content in

Question

I want to show 7000 files content that are in a folder and in excel?

I have a found a piece of code that helped me but its only reading one by one. However, I want to read 7000 all in one go. Please help.

 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

The code which you are using will be very slow when you are reading 7000 files. Also there is no code which can read 7000 files in 1 go. You will have to loop through the 7000 files. However there is one good news :) Instead of looping through every line in the text file, you can read the entire file into an array and then write it to excel. For example see this code which is very fast as compared to the code that you have above.

TRIED AND TESTED

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

Now using the same code in a loop we can write it into an Excel File

'~~> 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

What the above code does is that it reads the contents of the 7000 text files in sheet 1 (one below the other). Also I have not included error handling. Please do that.

CAUTION: If you are reading heavy text files, say, each file has 10000 lines then you will have to tweak the code in the above scenario as you will get errors. for example

7000 Files * 10000 lines = 70000000 lines

Excel 2003 has 65536 rows and Excel 2007/2010 has 1048576 rows.

So once the WriteRow reaches the maximum row, you might want to read the text file contents into Sheet 2 and so on...

HTH

Sid

Answer 2

Taking Siddharth's solution a little further. You probably don't want to write each row one at a time, calls to the worksheet are extremely slow in Excel, it is better to do any looping in memory and write back in one fell swoop :)

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