Search multiple strings in multiple wkb with multiple sheets

My code for 1 search street works but I can’t get my code for multiple strings to work.


my code for multiple strings includes this:

I can’t figure out where to incorporate it below.

Dim w as Long

Dim VSearch as Variant

VSearch = Array(“internal audit”,”irregularity investigation”,”8010″,”employee injury”, _

“security investigation”, “dot driver qualification”,”drug”,”alcohol”, _

“employee assessment”,”harassment”,”staffing plan”, _

“performance assessment”,”salary planning”,”leasing authority”)

For w = LBound(VSearch) To UBound(VSearch)

                Set rFound = wks.UsedRange.Find(VSearch)

next w

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 = “O:Information Management ServicesInformation Management & ComplianceAuditDataScans”

    strSearch = “drug”


    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, _



            For Each wks In wbk.Worksheets

                Set rFound = wks.UsedRange.Find(strSearch)

                If Not rFound Is Nothing Then

                    strFirstAddress = rFound.Address

                End If


                    If rFound Is Nothing Then

                        Exit Do


                        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



            wbk.Close (False)

            strFile = Dir



    End With

    MsgBox “Done”



    Set wOut = Nothing

    Set wks = Nothing

    Set wbk = Nothing

    Set fld = Nothing

    Set fso = Nothing

    Application.ScreenUpdating = True

    Exit Sub



    MsgBox Err.Description, vbExclamation

    Resume ExitHandler

End Sub


By: Judy

Leave a Reply

Your email address will not be published. Required fields are marked *