VBA Code will not search subfolders.

[benson8708]

How can I get this code to search all included subfolders within the selected folder? The code below will prompt me to enter a folder and then prompt a search string. It works perfectly except it will not search any sub folders with in the selected folder.
Please advise.

Sub SearchWKBooks()
Dim WS As Worksheet
Dim myfolder As String
Dim Str As String
Dim a As Single
Dim sht As Worksheet
Set WS = Sheets.Add
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    myfolder = .SelectedItems(1) & "\"
End With
Str = Application.InputBox(prompt:="Search string:", Title:="Search all workbooks in a folder", Type:=2)
If Str = "" Then Exit Sub
WS.Range("A1") = "Search string:"
WS.Range("B1") = Str
WS.Range("A2") = "Path:"
WS.Range("B2") = myfolder
WS.Range("A3") = "Workbook"
WS.Range("B3") = "Worksheet"
WS.Range("C3") = "Cell Address"
WS.Range("D3") = "Link"
a = 0
Value = Dir(myfolder)
Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If Right(Value, 4) = "xlsx" And Left(Value, 4) = "Zone" Then
            On Error Resume Next
            Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
            If Err.Number > 0 Then
                WS.Range("A4").Offset(a, 0).Value = Value
                WS.Range("B4").Offset(a, 0).Value = "Password protected"
                a = a + 1
            Else
                On Error GoTo 0
                For Each sht In ActiveWorkbook.Worksheets                        Set c = sht.Cells.Find(Str, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
                        If Not c Is Nothing Then
                            firstAddress = c.Address
                            Do
                                WS.Range("A4").Offset(a, 0).Value = Value
                                WS.Range("B4").Offset(a, 0).Value = sht.Name
                                WS.Range("C4").Offset(a, 0).Value = c.Address
                                WS.Hyperlinks.Add Anchor:=WS.Range("D4").Offset(a, 0), Address:=myfolder & Value, SubAddress:= _
                                sht.Name & "!" & c.Address, TextToDisplay:="Link"
                                a = a + 1
                                Set c = sht.Cells.FindNext(c)
                            Loop While Not c Is Nothing And c.Address <> firstAddress
                        End If
                Next sht
            End If
            Workbooks(Value).Close False
            On Error GoTo 0
        End If
    End If
    Value = Dir
Loop
Cells.EntireColumn.AutoFit
End Sub

[benson8708]

Anybody?

[Kenneth Hobs]

There are two methods to get subfolder file paths. You can use a scripting.filesystemobject (FSO) recursive method or one like this:

Sub aFFs_Test()  
  Dim x() As Variant, s() As String, i As Long
  x() = aFFs("c:\myfiles\excel\msword\*.doc")
  MsgBox Join(x, vbLf)
  For i = LBound(x) To UBound(x)
    'Do your thing here, e.g.
    'MsgBox x(i)
  Next i
End Sub


Sub MyFoldersAndDatesCreated()
  Dim a() As Variant, b() As Variant, i As Long
  Dim fso As Object
  
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  a() = aFFs("x:\", "/ad", True)
  
  'MsgBox Join(a(), vbLf)
  Range("A1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(a)
  
  b() = a() 'Set array to holder folder creation dates the same size
  For i = LBound(a) To UBound(a)
    b(i) = fso.GetFolder(b(i)).DateCreated
  Next i
  
  Range("B1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(b)
  
  Range("A:B").EntireColumn.AutoFit
End Sub




'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
  Optional tfSubFolders As Boolean = False) As Variant
  
  Dim s As String, a() As String, v As Variant
  Dim b() As Variant, i As Long
  
  If tfSubFolders Then
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
    Else
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
  End If
  
  a() = Split(s, vbCrLf)
  If UBound(a) = -1 Then
    MsgBox myDir & " not found.", vbCritical, "Macro Ending"
    Exit Function
  End If
  ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
  
  For i = 0 To UBound(a)
    If Not tfSubFolders Then
      s = Left$(myDir, InStrRev(myDir, "\"))
      'add the folder name
      a(i) = s & a(i)
    End If
  Next i
  aFFs = sA1dtovA1d(a)
End Function


Function sA1dtovA1d(strArray() As String) As Variant
  Dim varArray() As Variant, i As Long
  ReDim varArray(LBound(strArray) To UBound(strArray))
  For i = LBound(strArray) To UBound(strArray)
    varArray(i) = CVar(strArray(i))
  Next i
  sA1dtovA1d = varArray()
End Function

[benson8708]

Thanks for that. That code is a little above my pay grade. I ran it and it propagates a list of all the subfolders, but how do I use that info with the code that I already had? Is there away to integrate that in to my existing code?

[Kenneth Hobs]

I guess that I could finish this for you but you will learn more doing it yourself. I added a bit more FSO to show you how to parse the full path filename to use as you see fit. The more efficient way would be to dim and array with the the first elements being say 0 to 3 for your first 4 columns of data, and then write the array all at once. I used a single dimension array for illustration purposes mostly but even that is far faster than writing out one cell at a time.

It should not take that much work to concatenate the folder from your current code to the "Zone*.xlsx" to pass to my aFFs() routine. Here again, that is far faster than, getting all files and running If's to check file extension and filename suffix.

Sub MyFoldersAndDatesCreated()    
    Dim a() As Variant, b() As Variant, i As Long
    Dim fso As Object
    Dim c() As Variant, d() As Variant
    
    'FSO Details: https://msdn.microsoft.com/en-us/library/hww8txat(v=vs.84).aspx
    Set fso = CreateObject("Scripting.FileSystemObject")
     
    'a() = aFFs("x:\", "/ad", True) 'Folders only
    a() = aFFs("x:\Zone*.xlsx", , True) 'Wildcard filenames
     
     'MsgBox Join(a(), vbLf)
    Range("A1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(a)
     
    b() = a()
    c() = a()
    d() = a()
    For i = LBound(a) To UBound(a)
      'Get folder's date created
      'b(i) = fso.GetFolder(b(i)).DateCreated
      'Get file's basename
      b(i) = fso.GetBasename(b(i))  'No file extension
      c(i) = fso.GetParentFoldername(a(i)) 'Parent Folder Name
      'd(i) = fso.Getfile(a(i)).Name 'Get only file basename with file extension
      d(i) = fso.GetFilename(a(i)) 'Another way to get only file basename with file extension
    Next i
     
    Range("B1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(b)
    Range("C1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(c)
    Range("D1").Resize(UBound(a) + 1, 1).Value2 = WorksheetFunction.Transpose(d)
     
    Range("A:D").EntireColumn.AutoFit
End Sub