Чтение всех файлов в папке и показ содержимого в Excel

Question

Я хочу показать 7000 файлов содержимого, которые находятся в папке и в Excel?

Я нашел фрагмент кода, который мне помог, но он читает только один за другим. Тем не менее, я хочу прочитать 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

. Приведенный выше код выполняет то, что он считывает содержимое 7000 текстовых файлов на листе 1 (один под другим).Также я не включил обработку ошибок.Пожалуйста, сделайте это.

ВНИМАНИЕ : если вы читаете тяжелые текстовые файлы, скажем, каждый файл имеет 10000 строк, то вам придется настроить код в приведенном выше сценарии, так как вы получите ошибки,например,

7000 файлов * 10000 строк = 70000000 строк

В Excel 2003 имеется 65536 строк, а в Excel 2007/2010 - 1048576 строк.

Так что когда-то WriteRow достигает максимальной строки, вы можете прочитать содержимое текстового файла на листе 2 и т. Д. ...

HTH

Sid

Answer 2

Принятие решения Сиддхарта немного дальше. Вы, вероятно, не хотите записывать каждую строку по одному, вызовы на листе в 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