VBA Code to search for a string through multiple workbooks

VBA Code to search for a string through multiple workbooks

December 12, 2017

The great Allen Wyatt has posted visual basic code here which will allow you to search through multiple workbooks for a string. 

 

It's very easy to edit the code to suit your purposes.   Simply paste the below code in a new module, and then list the path containing your workbooks in the line beginning, strPath, and your search term in the line beginning, strSearch.    

 

 

 

This macro will generate results showing the exact location of the hits by workbook, worksheet, and cell, and also all text in the cell in which the string appears. 

 

 

 

 

 

 

 

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:\FooFolder\baseball\xls"
    strSearch = "ruthba01"

    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


 

 

 

 

 

Please reload

Some elements on this page did not load. Refresh your site & try again.

Contact Me With Your Litigation Support Questions:

seankevinoshea@hotmail.com

  • Twitter Long Shadow

© 2015 by Sean O'Shea . Proudly created with Wix.com