VBA Recursive to Search Through Subfolders and Attach Matching Files - excel

Question

I have a macro that works to create emails, attach files. It runs and I use a recursive function to search through the directory to find files, match them to a field in the spreadsheet, and then attach them once found. It works and has worked for a while. However, they have added a level in the directory and now for some reason, it will not work. I am adding here the recursive section only, as that is where the error happens.
EDIT: For some reason when running from this new, higher level, it skips all the files that have numbers in the filename. Those filename numbers are what the macro uses to compare against the number in the field, so when it skips them it fails. So why would it skip them now, but work fine when running from the next subfolder down from the root directory?
Here is a sample directory to show how it looks, with Division being the root top folder. SubfolderD is where I want it to get to, find the data:
Division-->SubfolderA-->Subfolder2-->Subfolder3-->Etc
Division-->SubfolderB-->Subfolder2-->Subfolder3-->Etc
Division-->SubfolderC-->Subfolder2-->Subfolder3-->Etc
Division-->SubfolderD-->Subfolder2-->Subfolder3-->Etc
I can adjust the function to search at the SubfolderD and it will find the files. The issue is that new folders will be added and the files to be found may be in the other folders. So I need to get it to work from the Division folder consistently. I have stepped through the sub with F8 and I have looked at the debug print in the Immediate window. It seems to get all the way through SubfolderC, but then stops and for some reason seems to give up. Any thoughts? Thanks
Function recurse(sPath As String, strname As String, strName3 As String)
Dim FSO As New FileSystemObject
Dim myFolder As Scripting.Folder
Dim mySubFolder As Scripting.Folder
Dim myFile As Scripting.file
Dim strJDFile As String
Dim strDir As String
Dim strJDName As String
Set myFolder = FSO.GetFolder(sPath)
' strName = Range("a2").Offset(0, 3)
strName3 = Replace(strName3, "/", " ")
For Each mySubFolder In myFolder.SubFolders
Debug.Print " mySubFolder: " & mySubFolder
For Each myFile In mySubFolder.Files
If "*" & myFile.Name & "*" Like "*" & strName3 & "*" Then
strJDName = myFile.Name
strDir = mySubFolder & "\"
strJDFile = strDir & strJDName
recurse = strJDFile
Exit Function
Else
Debug.Print " myFile.name: " & myFile.Name
End If
Next
recurse = recurse(mySubFolder.Path, strname, strName3)
Next
End Function
Edited to Post Entire Sub:
Option Compare Text
Sub Recursive()
'
'
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strname As String
Dim strName1 As String
Dim strName3 As String
Dim strDept As String
Dim strName2 As String
Dim LR As Long
Dim oItem As Object
Dim dteSat As Date
Dim nextSat As Date
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Test.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Select Case Time
Case 0.25 To 0.5
GreetTime = "Good morning"
Case 0.5 To 0.71
GreetTime = "Good afternoon"
Case Else
GreetTime = "Good evening"
End Select
With ActiveSheet
With .Columns(2)
.NumberFormat = "General"
.TextToColumns Destination:=.Cells(1), _
DataType:=xlFixedWidth, fieldinfo:=Array(0, 1)
End With
End With
With Item
K = Weekday(Today)
dteSat = Now() + (10 - K)
nextSat = Date + 7 - Weekday(Date, vfSaturday)
End With
LR = ActiveSheet.UsedRange.Rows.Count
Columns("z:z").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("z2") = "Yes"
Range("z2").AutoFill Destination:=Range("z2:z" & LR)
For Each cell In Columns("J").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "z").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
strName3 = Cells(cell.Row, "b").Value
strName1 = Cells(cell.Row, "d").Value
strName2 = Trim(Split(strName1, " ")(1))
strname = Cells(cell.Row, "a").Value
strJDFile = recurse("z:\Division", strname, strName3)
strBody = "<Font Face=calibri><br><br>The form needs to be completed no later " & _
"than next week. <br><br>" & _
.SentOnBehalfOfName = ""
.To = cell.Value
.Subject = "Please Reply"
.HTMLBody = "<Font Face=calibri>" & GreetTime & " " & strName1 & ", " & strBody & "<br>" & signature
.Attachments.Add strJDFile
.Display 'Or use Send
End With
Set OutMail = Nothing
End If
Next cell
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim FSO As Object
Dim ts As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function
Function recurse(sPath As String, strname As String, strName3 As String)
Dim FSO As New FileSystemObject
Dim myFolder As Scripting.Folder
Dim mySubFolder As Scripting.Folder
Dim myFile As Scripting.file
Dim strJDFile As String
Dim strDir As String
Dim strJDName As String
Set myFolder = FSO.GetFolder(sPath)
' strName = Range("a2").Offset(0, 3)
strName3 = Replace(strName3, "/", " ")
For Each mySubFolder In myFolder.SubFolders
Debug.Print " mySubFolder: " & mySubFolder
For Each myFile In mySubFolder.Files
If "*" & myFile.Name & "*" Like "*" & strName3 & "*" Then
strJDName = myFile.Name
strDir = mySubFolder & "\"
strJDFile = strDir & strJDName
recurse = strJDFile
Exit Function
Else
Debug.Print " myFile.name: " & myFile.Name
End If
Next
recurse = recurse(mySubFolder.Path, strname, strName3)
Next
End Function

Answer 1

just wanted to let you know I figured it out. Everything was working the way it should but it was still not finding, skipping certain files. It appears there was an issue with this particular problem in Office. I updated MS Office (all applications) along with Windows to the latest win10 version and it worked!
Thanks again