Adjust VBA to search in Sub-folders

[anewman5high]

Hi all,

I have a piece of VBA code which searches through all the .xls files in a folder and looks for a particular word then pulls out other info in the same row if it finds it. It as working great until some "useful" person on my team decided they wanted to reorder the folders and create a whole bunch of sub-folders. What I can't seem to work out how to do is modify the code to look in the subfolders, this seems like it should be far simpler than I am making it!

This is the previously working code, if someone can advise me how to tweak it then I'd be really grateful!

Alan

Sub CopyRange()    Application.ScreenUpdating = False
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
    Set wkbDest = ThisWorkbook
    Dim LastRow As Long
    Dim wOut As Worksheet
    Dim wks As Worksheet
    Dim rFound As Range
    Dim strFirstAddress As String
    Dim strSearch As String
    Const strPath As String = "J:\Wessex\NETSCC\A&F\HTA Programme\Reviewing\!Previous Reviewing Rounds & Tidying Up\"
    ChDir strPath
    strExtension = Dir("*.xls*")
    strSearch = InputBox("Please enter the Search Term.")
    Set wOut = Worksheets.Add
    wOut.Range("A1:D1") = Array("Workbook", "Worksheet", "Cell", "Text in Cell")
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        With wkbSource
            For Each wks In .Sheets
                Set rFound = wks.Range("A17:A100").Find(strSearch, LookIn:=xlValues, lookat:=xlWhole)
                If Not rFound Is Nothing Then
                    strFirstAddress = rFound.Address
                    Do
                        wOut.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = wkbSource.Name
                        wOut.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = wks.Name
                        wOut.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = rFound.Address
                        wOut.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = rFound.Value
                        'wks.Range(wks.Cells(rFound.Row, 1), wks.Cells(wks.Cells(rFound.Row, Columns.Count).End(xlToLeft).Column)).Copy wOut.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
                        wks.Range(wks.Cells(rFound.Row, 1), wks.Cells(rFound.Row, wks.Cells(rFound.Row, wks.Columns.Count).End(xlToLeft).Column)).Copy wOut.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0)
                        Set rFound = wks.Range("A17:A100").FindNext(rFound)
                    Loop While rFound.Address <> strFirstAddress
                    sAddr = ""
                End If
            Next wks
        End With
        wkbSource.Close savechanges:=False
        strExtension = Dir
    Loop
    wOut.Range("A:Z").Cells.WrapText = False
    Worksheets("Home").Activate
    ActiveSheet.Pictures("Picture 6").Visible = False
        Application.ScreenUpdating = True
End Sub

 

[John_w]

Use a recursive FileSystemObject procedure to scan the folders and subfolders instead of the Dir loop. There should be example code in this forum.