Need to search in all files within all folders also.

[craigwojo]

Hi everyone,
I've been using a VBA and need to search "within" the existing folders in the search, not just the files in the folder excluding the folders. I hope you understand.
What can I do to make this macro search through all the ".xls*" files including the ".xls*" files buried in the folder within the search?

Thank you and God bless,
Craig

Sub SearchFolders()
Dim fso As Object
Dim fld As Object
Dim strSearch As String
Dim strPath As String
Dim strFile As String
Dim wOut As Worksheet
Dim wbk As Workbook
Dim wks As Worksheet
Dim lRow As Long
Dim rFound As Range
Dim strFirstAddress As String

On Error GoTo ErrHandler
Application.ScreenUpdating = False

'Change as desired
strPath = "c:\MyFolder"
strSearch = "Specific text"

Set wOut = Worksheets.Add
lRow = 1
With wOut
.Cells(lRow, 1) = "Workbook"
.Cells(lRow, 2) = "Worksheet"
.Cells(lRow, 3) = "Cell"
.Cells(lRow, 4) = "Text in Cell"
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strPath)

strFile = Dir(strPath & "\*.xls*")
Do While strFile <> ""
Set wbk = Workbooks.Open _
(Filename:=strPath & "\" & strFile, _
UpdateLinks:=0, _
ReadOnly:=True, _
AddToMRU:=False)

For Each wks In wbk.Worksheets
Set rFound = wks.UsedRange.find(strSearch)
If Not rFound Is Nothing Then
strFirstAddress = rFound.Address
End If
Do
If rFound Is Nothing Then
Exit Do
Else
lRow = lRow + 1
.Cells(lRow, 1) = wbk.Name
.Cells(lRow, 2) = wks.Name
.Cells(lRow, 3) = rFound.Address
.Cells(lRow, 4) = rFound.Value
End If
Set rFound = wks.Cells.FindNext(After:=rFound)
Loop While strFirstAddress <> rFound.Address
Next

wbk.Close (False)
strFile = Dir
Loop
.Columns("A:D").EntireColumn.AutoFit
End With
MsgBox "Done"

ExitHandler:
Set wOut = Nothing
Set wks = Nothing
Set wbk = Nothing
Set fld = Nothing
Set fso = Nothing
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub

 

[Domenic]

To loop through files in a folder and its subfolders, have a look at the following link...

VBA code to loop through files in a folder (and sub folders)

Looping through every file in a folder is a useful technique to make changes to lots of file. This post provides 6 different methods to achieve this.

exceloffthegrid.com

Hope this helps!

 

[craigwojo]

To loop through files in a folder and its subfolders, have a look at the following link...

VBA code to loop through files in a folder (and sub folders)

Looping through every file in a folder is a useful technique to make changes to lots of file. This post provides 6 different methods to achieve this.

exceloffthegrid.com

Hope this helps!

Thanks Domenic. Just lost on too much of the code. I'll look more into it.
Thank you and God bless,
Craig

 

[Domenic]

Try the following code...

Option Explicit

Sub SearchFolders()

    Dim strPath As String
    Dim strSearch As String
    Dim strErrorMessage As String
    Dim wksDestination As Worksheet
    Dim colFileNames As Collection
    Dim colRecords As Collection
    Dim objFSO As Object
    Dim blnCompleted As Boolean
    
    On Error GoTo errorHandler
    
    Application.ScreenUpdating = False

    strPath = "c:\MyFolder" 'change the path accordingly
    
    If Len(Dir(strPath, vbDirectory)) = 0 Then
        MsgBox "'" & strPath & "' does not exist!", vbExclamation
        Exit Sub
    End If
    
    strSearch = "Specific text"
    
    Set wksDestination = ThisWorkbook.Worksheets.Add
    
    Set colFileNames = New Collection
    
    Set colRecords = New Collection
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    If Not getFilesFromFolderAndSubfolders(strPath, objFSO, colFileNames, strErrorMessage) Then GoTo errorHandler
    
    If Not getRecordsFromFiles(colRecords, colFileNames, strSearch, strErrorMessage) Then GoTo errorHandler
    
    If Not createReport(wksDestination, colRecords, strErrorMessage) Then GoTo errorHandler
    
    blnCompleted = True
    
exitHandler:
    Application.ScreenUpdating = True
    
    If blnCompleted = True Then
        MsgBox "Number of records: " & colRecords.Count
    End If
    
    Set wksDestination = Nothing
    Set colFileNames = Nothing
    Set colRecords = Nothing
    Set objFSO = Nothing
    
    Exit Sub
    
errorHandler:
    If Len(strErrorMessage) > 0 Then
        MsgBox strErrorMessage, vbCritical
        GoTo exitHandler
    Else
        MsgBox "[SearchFolders]" & vbCrLf & vbCrLf & "Error " & Err.Number & ":" & vbCrLf & Err.Description, vbCritical
        Resume exitHandler
    End If
    
End Sub

Private Function getFilesFromFolderAndSubfolders(ByVal strPath As String, ByVal objFSO As Object, ByVal colFileNames As Collection, ByRef strErrorMessage) As Boolean

    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim objFile As Object
    
    On Error GoTo errorHandler
    
    Set objFolder = objFSO.GetFolder(strPath)
    
    For Each objFile In objFolder.Files
        colFileNames.Add objFile.Path
    Next objFile
    
    For Each objSubFolder In objFolder.SubFolders
        getFilesFromFolderAndSubfolders objSubFolder.Path, objFSO, colFileNames, strErrorMessage
    Next objSubFolder
    
    getFilesFromFolderAndSubfolders = True
    
    Exit Function
    
errorHandler:
    strErrorMessage = "[getFilesFromFolderAndSubfolders]" & vbCrLf & vbCrLf & "Error " & Err.Number & ":" & vbCrLf & Err.Description
    getFilesFromFolderAndSubfolders = False
    
End Function

Private Function getRecordsFromFiles(ByVal colRecords As Collection, ByVal colFileNames As Collection, ByVal strSearch As String, ByRef strErrorMessage As String) As Boolean

    Dim varFileName As Variant
    Dim wkbSource As Workbook
    
    On Error GoTo errorHandler
    
    For Each varFileName In colFileNames
        Set wkbSource = Workbooks.Open(fileName:=varFileName, UpdateLinks:=False, ReadOnly:=True, AddToMRU:=False)
        processWorkbook colRecords, wkbSource, strSearch
        wkbSource.Close SaveChanges:=False
    Next varFileName
    
    getRecordsFromFiles = True
    
    Exit Function
    
errorHandler:
    If Not wkbSource Is Nothing Then
        wkbSource.Close SaveChanges:=False
    End If
    strErrorMessage = "[getRecordsFromFiles]" & vbCrLf & vbCrLf & "Error " & Err.Number & ":" & vbCrLf & Err.Description
    getRecordsFromFiles = False
    
End Function

Private Sub processWorkbook(ByVal colRecords As Collection, ByVal wkbSource As Workbook, ByRef strSearch As String)

    Dim wksSource As Worksheet
    Dim rngFound As Range
    Dim strFirstAddress As String
    Dim nextRow As Long
    
    For Each wksSource In wkbSource.Worksheets
        With wksSource.UsedRange
            Set rngFound = .Find(what:=strSearch, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False) 'change as desired
            If Not rngFound Is Nothing Then
                strFirstAddress = rngFound.Address
                Do
                    colRecords.Add Array(wkbSource.Name, wksSource.Name, rngFound.Address, rngFound.Value)
                    Set rngFound = .FindNext(after:=rngFound)
                Loop While rngFound.Address <> strFirstAddress
            End If
        End With
    Next wksSource
    
End Sub

Private Function createReport(ByVal wksDestination As Worksheet, ByVal colRecords As Collection, ByRef strErrorMessage As String) As Boolean

    Dim nextRow As Long
    Dim varItem As Variant
    
    On Error GoTo errorHandler

    With wksDestination
        .Cells(1, 1) = "Workbook"
        .Cells(1, 2) = "Worksheet"
        .Cells(1, 3) = "Cell"
        .Cells(1, 4) = "Text in Cell"
    End With
    
    nextRow = 2
    For Each varItem In colRecords
        wksDestination.Cells(nextRow, 1).Resize(, UBound(varItem) + 1).Value = varItem
        nextRow = nextRow + 1
    Next varItem
    
    wksDestination.Columns.AutoFit
    
    createReport = True
    
    Exit Function
    
errorHandler:
    strErrorMessage = "[createReport]" & vbCrLf & vbCrLf & "Error " & Err.Number & ":" & vbCrLf & Err.Description
    createReport = False
    
End Function

Hope this helps!

 

[craigwojo]

Try the following code...

Option Explicit

Sub SearchFolders()

    Dim strPath As String
    Dim strSearch As String
    Dim strErrorMessage As String
    Dim wksDestination As Worksheet
    Dim colFileNames As Collection
    Dim colRecords As Collection
    Dim objFSO As Object
    Dim blnCompleted As Boolean
   
    On Error GoTo errorHandler
   
    Application.ScreenUpdating = False

    strPath = "c:\MyFolder" 'change the path accordingly
   
    If Len(Dir(strPath, vbDirectory)) = 0 Then
        MsgBox "'" & strPath & "' does not exist!", vbExclamation
        Exit Sub
    End If
   
    strSearch = "Specific text"
   
    Set wksDestination = ThisWorkbook.Worksheets.Add
   
    Set colFileNames = New Collection
   
    Set colRecords = New Collection
   
    Set objFSO = CreateObject("Scripting.FileSystemObject")
   
    If Not getFilesFromFolderAndSubfolders(strPath, objFSO, colFileNames, strErrorMessage) Then GoTo errorHandler
   
    If Not getRecordsFromFiles(colRecords, colFileNames, strSearch, strErrorMessage) Then GoTo errorHandler
   
    If Not createReport(wksDestination, colRecords, strErrorMessage) Then GoTo errorHandler
   
    blnCompleted = True
   
exitHandler:
    Application.ScreenUpdating = True
   
    If blnCompleted = True Then
        MsgBox "Number of records: " & colRecords.Count
    End If
   
    Set wksDestination = Nothing
    Set colFileNames = Nothing
    Set colRecords = Nothing
    Set objFSO = Nothing
   
    Exit Sub
   
errorHandler:
    If Len(strErrorMessage) > 0 Then
        MsgBox strErrorMessage, vbCritical
        GoTo exitHandler
    Else
        MsgBox "[SearchFolders]" & vbCrLf & vbCrLf & "Error " & Err.Number & ":" & vbCrLf & Err.Description, vbCritical
        Resume exitHandler
    End If
   
End Sub

Private Function getFilesFromFolderAndSubfolders(ByVal strPath As String, ByVal objFSO As Object, ByVal colFileNames As Collection, ByRef strErrorMessage) As Boolean

    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim objFile As Object
   
    On Error GoTo errorHandler
   
    Set objFolder = objFSO.GetFolder(strPath)
   
    For Each objFile In objFolder.Files
        colFileNames.Add objFile.Path
    Next objFile
   
    For Each objSubFolder In objFolder.SubFolders
        getFilesFromFolderAndSubfolders objSubFolder.Path, objFSO, colFileNames, strErrorMessage
    Next objSubFolder
   
    getFilesFromFolderAndSubfolders = True
   
    Exit Function
   
errorHandler:
    strErrorMessage = "[getFilesFromFolderAndSubfolders]" & vbCrLf & vbCrLf & "Error " & Err.Number & ":" & vbCrLf & Err.Description
    getFilesFromFolderAndSubfolders = False
   
End Function

Private Function getRecordsFromFiles(ByVal colRecords As Collection, ByVal colFileNames As Collection, ByVal strSearch As String, ByRef strErrorMessage As String) As Boolean

    Dim varFileName As Variant
    Dim wkbSource As Workbook
   
    On Error GoTo errorHandler
   
    For Each varFileName In colFileNames
        Set wkbSource = Workbooks.Open(fileName:=varFileName, UpdateLinks:=False, ReadOnly:=True, AddToMRU:=False)
        processWorkbook colRecords, wkbSource, strSearch
        wkbSource.Close SaveChanges:=False
    Next varFileName
   
    getRecordsFromFiles = True
   
    Exit Function
   
errorHandler:
    If Not wkbSource Is Nothing Then
        wkbSource.Close SaveChanges:=False
    End If
    strErrorMessage = "[getRecordsFromFiles]" & vbCrLf & vbCrLf & "Error " & Err.Number & ":" & vbCrLf & Err.Description
    getRecordsFromFiles = False
   
End Function

Private Sub processWorkbook(ByVal colRecords As Collection, ByVal wkbSource As Workbook, ByRef strSearch As String)

    Dim wksSource As Worksheet
    Dim rngFound As Range
    Dim strFirstAddress As String
    Dim nextRow As Long
   
    For Each wksSource In wkbSource.Worksheets
        With wksSource.UsedRange
            Set rngFound = .Find(what:=strSearch, LookIn:=xlValues, lookat:=xlPart, MatchCase:=False) 'change as desired
            If Not rngFound Is Nothing Then
                strFirstAddress = rngFound.Address
                Do
                    colRecords.Add Array(wkbSource.Name, wksSource.Name, rngFound.Address, rngFound.Value)
                    Set rngFound = .FindNext(after:=rngFound)
                Loop While rngFound.Address <> strFirstAddress
            End If
        End With
    Next wksSource
   
End Sub

Private Function createReport(ByVal wksDestination As Worksheet, ByVal colRecords As Collection, ByRef strErrorMessage As String) As Boolean

    Dim nextRow As Long
    Dim varItem As Variant
   
    On Error GoTo errorHandler

    With wksDestination
        .Cells(1, 1) = "Workbook"
        .Cells(1, 2) = "Worksheet"
        .Cells(1, 3) = "Cell"
        .Cells(1, 4) = "Text in Cell"
    End With
   
    nextRow = 2
    For Each varItem In colRecords
        wksDestination.Cells(nextRow, 1).Resize(, UBound(varItem) + 1).Value = varItem
        nextRow = nextRow + 1
    Next varItem
   
    wksDestination.Columns.AutoFit
   
    createReport = True
   
    Exit Function
   
errorHandler:
    strErrorMessage = "[createReport]" & vbCrLf & vbCrLf & "Error " & Err.Number & ":" & vbCrLf & Err.Description
    createReport = False
   
End Function

Hope this helps!

Yes, it did Domenic. Thank you always.

 

[Domenic]

That's great to hear, I'm glad I could help.

Cheers!