Update VBA script to search subfolders excel - 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