Update VBA script to search subfolders excel

Question

I previously got help to write read through several textfiles in a folder and organize the data in a spreadsheet. I got this script from @trincot that worked well for my need. How to import specific text from files in to excel?

Sub ReadFilesIntoActiveSheet()
Dim fso As FileSystemObject
Dim folder As folder, file As file, FileText As TextStream
Dim TextLine As String
Dim cl As Range

Dim num As Long ' numerical part of key, as in "Ann:"
Dim col As Long ' target column in Excel sheet
Dim key As String ' Part before ":"
Dim value As String ' Part after ":"

' Get a FileSystem object
Set fso = New FileSystemObject

' Get the directory you want
Set folder = fso.GetFolder("D:\YourDirectory\")

' Set the starting point to write the data to
' Don't write in first row where titles are
Set cl = ActiveSheet.Cells(2, 1)

' Loop thru all files in the folder
For Each file In folder.Files
    ' Open the file
    Set FileText = file.OpenAsTextStream(ForReading)

    ' Read the file one line at a time
    Do While Not FileText.AtEndOfStream

        TextLine = FileText.ReadLine 'read line

        key = Split(TextLine & ":", ":")(0)
        value = Trim(Mid(TextLine, Len(key)+2))
        num = Val(Mid(key,2))
        If num Then key = Replace(key, num, "") ' Remove number from key
        col = 0
        If key = "From" Then col = 1
        If key = "Date" Then col = 2
        If key = "A"    Then col = 2 + num
        If col Then
            cl.Offset(, col-1).Value = value ' Fill cell
        End If
    Loop

    ' Clean up
    FileText.Close
    ' Next row
    Set cl = cl.Offset(1) 
Next file
End Sub

The problem I figured out afterwards was that my textfiles will in time start to be stored in subfolders within a subfolder, and this script is not written to handle this.

I found this script by @Cor_Blimey here Loop Through All Subfolders Using VBA

Public Sub NonRecursiveMethod()
Dim fso, oFolder, oSubfolder, oFile, queue As Collection

Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder("your folder path variable") 'obviously replace

Do While queue.Count > 0
    Set oFolder = queue(1)
    queue.Remove 1 'dequeue
    '...insert any folder processing code here...
    For Each oSubfolder In oFolder.SubFolders
        queue.Add oSubfolder 'enqueue
    Next oSubfolder
    For Each oFile In oFolder.Files
        '...insert any file processing code here...
    Next oFile
Loop

End Sub

And the two answers here Loop through all subfolders and files under a folder and write the last modifed date information to an Excel spreadsheet by @L42 and @chris nielsen.

I also tried a bit with TraversFolder function, but I have not been able to incorporate any of these solutions into my existing script. Any help would be much appreciated!

Answer 1

Put your function in section marked "HERE COMES YOUR READING CODE Function is one of mine I used in projects. I deleted the surplus code and it should do its task.

Sub index()
ThisWorkbook.Save
DoEvents
Dim intResult As Integer
Dim strPath As String
Dim objFSO As Object
Dim intCountRows As Integer

Application.FileDialog(msoFileDialogFolderPicker).Title = "Vyberte prosím složku"
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Vybrat složku"
Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = True

intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
If intResult = 0 Then
    End
End If
For Each Item In Application.FileDialog(msoFileDialogFolderPicker).SelectedItems
        strPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) 'ulož cestu ke složce
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        intCountRows = GetAllFiles(strPath, ROW_FIRST, objFSO)
        Call GetAllFolders(strPath, objFSO, intCountRows)
Next Item
End Sub

Private Function GetAllFiles(ByVal strPath As String, ByVal intRow As Integer, ByRef objFSO As Object) As Integer
DoEvents
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer

i = intRow + 1
Set objFolder = objFSO.GetFolder(strPath)

For Each objFile In objFolder.Files
        If Right(objFile.Name, 3) = "txt" Then
                    'HERE COMES YOU READING CODE
                    i = i + 1
        End If
Next objFile
GetAllFiles = i + ROW_FIRST - 1

End Function

Private Sub GetAllFolders(ByVal strFolder As String, ByRef objFSO As Object, ByRef intRow As Integer)
DoEvents
Dim objFolder As Object
Dim objSubFolder As Object
Set objFolder = objFSO.GetFolder(strFolder)
For Each objSubFolder In objFolder.subfolders
        intRow = GetAllFiles(objSubFolder.Path, intRow, objFSO)
        Call GetAllFolders(objSubFolder.Path, objFSO, intRow)
Next objSubFolder
End Sub