Search text in multiple Workbooks in a folder including subfolder

[dmegginson]

Hi,

I have a folder called tagnumbers and with in that one there is a bunch of folders with with company names and in those are workbooks with numbers in them
I am trying to create a macro that will allow me to enter a number such as 12345 and have it then look through all my workbooks (around 100 or so) and worksheets with in them (around 20-30) and see if it is entered anywhere in them.
If it is found I would like it to just tell me what workbook it is in and what the sheet name is that it was found in. That is all.

so far I can make it do what I want but I can't get it to loop through all the subfolders. right now I have put each folder path in the code then search then change the path to a different one and do the search again.

Is there a way I can just set the folder path to C:\tagnumbers\
and have it look through the subfolders automatically?
that way I won't have to keep going in to change the path in the code.


Thanks for the help.
DAN.

 

[dmegginson]

This is the code I am working with right now, it is just bits and pieces I have found over the net as I am pretty new to VBA

Sub SearchFolders()
    Dim fso As Object
    Dim fld As Object
    Dim sfl As Object
    Dim strSearch As String
    Dim strPath As String
    Dim strFile As String
    Dim company 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:\tagnumbers"
    strSearch = InputBox("What do you want to search for?")
  
    
    Set wOut = Sheet1
    lRow = 7
    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 & "\*.xl* ")
        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 sfl = Nothing
    Set fld = Nothing
    Set fso = Nothing
    Application.ScreenUpdating = True
    Exit Sub

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

 

[dmegginson]

bump...

 

[dmegginson]

Anyone got an fix for this?