Speed up finding txt files in nested folder structure - excel

Question

This code finds a txt file with a variable name in a folder structure with variable names.
The underlined parts are the variable parts that I can't know
and further back the folder structure looks like this:
sub Main()
Dim FileSystem As Object
Dim HostFolder As String
' for loop that loops multiple days omitted for simplicity
HostFolder = "H:\Dokument\Avvikelser\" & Format(dd, "YYYY\\mm\\dd") ' dd is the date it should look at
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
End sub
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
'Debug.Print SubFolder
' since I don't need to look in the folder called 51562 I added the if below
If IsNumeric(Right(SubFolder, 5)) = False Then DoFolder SubFolder
DoEvents
Next
Dim File
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
For Each File In Folder.Files
' only the text file is interesting
If Right(File, 3) = "txt" Then
Debug.Print File
objStream.Charset = "utf-8"
objStream.Open
objStream.LoadFromFile (File)
cont = objStream.ReadText()
objStream.Close
Set objStream = Nothing
' strData is a public string that is appended with multiple textfiles contents
strData = strData & cont
DoEvents
End If
Next
End Sub
The barebone of the code is copied from https://stackoverflow.com/a/22645439/5159168
The issue I have is that even though I have tried to make it only traverse the parts it has to it still takes about 2-2.5 seconds between each file is read.
Is there anything that I can do to make this faster?

Answer 1

Example of how to split your procedures (so each of them does less things): The first one GetAllTextFilesFromNonNumericSubFolders just collects the text files of all non numeric sub folders and collects them in a FileList. The second one ProceedTextFiles then uses the FileList to work with these text files.
Now you can easily check out which one is the bottleneck. Just comment out ProceedTextFiles FileList in your Main() procedure. If this runs fast the bottleneck is not looping through the folders. If it is slow, you can try to find an more optimized way of collecting the text files.
Option Explicit
Public Sub Main()
Dim HostFolder As String
HostFolder = "H:\Dokument\Avvikelser\" & Format(dd, "YYYY\\mm\\dd")
Dim FileSystem As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")
Dim FileList As New Collection
GetAllTextFilesFromNonNumericSubFolders FileSystem.GetFolder(HostFolder), FileList
If FileList.Count > 0 Then
ProceedTextFiles FileList
Else
MsgBox "No text files found in '" & HostFolder & "'.", vbExclamation
End If
End Sub
Public Sub GetAllTextFilesFromNonNumericSubFolders(ByVal Folder As Folder, ByRef FileList As Collection)
Dim SubFolder As Variant
For Each SubFolder In Folder.SubFolders
'Debug.Print SubFolder
' since I don't need to look in the folder called 51562 I added the if below
If IsNumeric(Right(SubFolder, 5)) = False Then GetAllTextFilesFromNonNumericSubFolders SubFolder, FileList
DoEvents 'ToDo: remove this line to optimize speed
Next
Dim File As Variant
For Each File In Folder.Files
' only the text file is interesting
If Right(File, 3) = "txt" Then
Debug.Print File 'ToDo: remove this line to optimize speed
FileList.Add File
End If
Next
End Sub
Public Sub ProceedTextFiles(ByVal FileList As Collection)
Dim objStream As Variant
Set objStream = CreateObject("ADODB.Stream")
Dim File As Variant
For Each File In FileList
Debug.Print File 'ToDo: remove this line to optimize speed
objStream.Charset = "utf-8"
objStream.Open
objStream.LoadFromFile File
cont = objStream.ReadText()
objStream.Close
Set objStream = Nothing
' strData is a public string that is appended with multiple textfiles contents
strData = strData & cont
DoEvents 'ToDo: remove this line to optimize speed
Next File
End Sub
Note that the ByRef FileList in the GetAllTextFilesFromNonNumericSubFolders procedure is a return variable. Because it is ByRef the changes made in teh procedure are returned back to the Main procedure.
Alternative:
Give the follwing a try. This uses the dir *.txt /A-H-S /B /S command to go through the subfolders and should be much quicker.
Option Explicit
Public Sub Main()
Dim HostFolder As String
HostFolder = "H:\Dokument\Avvikelser\" & Format(dd, "YYYY\\mm\\dd")
Dim FileList() As String
FileList = GetAllTextFilesSubFolders(HostFolder)
If (Not Not FileList) <> 0 Then
ProceedTextFiles FileList
Else
MsgBox "No text files found in '" & HostFolder & "'.", vbExclamation
End If
End Sub
Public Function GetAllTextFilesSubFolders(ByVal Folder As String) As Variant
GetAllTextFilesSubFolders = Split(CreateObject("WScript.Shell").Exec("cmd /c dir """ & Folder & "\""*.txt /A-H-S /B /S").StdOut.ReadAll, vbNewLine)
End Function
Public Sub ProceedTextFiles(ByRef FileList() As String)
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
Dim File As Variant
For Each File In FileList
Debug.Print File
objStream.Charset = "utf-8"
objStream.Open
objStream.LoadFromFile File
cont = objStream.ReadText()
objStream.Close
Set objStream = Nothing
' strData is a public string that is appended with multiple textfiles contents
strData = strData & cont
DoEvents
Next File
End Sub
Added by OP.
UTF-8 version
Since you can't read the cmd window in UTF-8, the easy dirty hack is to replace the wrong characters in the string before you split.
Public Function GetAllTextFilesSubFolders(ByVal Folder As String) As Variant
GetAllTextFilesSubFolders = Split(Replace(Replace(Replace(CreateObject("WScript.Shell").Exec("cmd /c dir """ & Folder & "\""*.txt /A-H-S /B /S").StdOut.ReadAll, "†", "å"), "„", "ä"), "”", "ö"), vbNewLine)
End Function
2 seconds!