Search Multiple Words In Excel

I added a section to make sure that you don’t select any blank cells. Since there are a gazillion blank cells in every workbook, the code will find them and run forever.

I also commented out the instructions that populate A1 and B1. Those instructions are expecting a single search string, which we no longer have.

Sub SearchWKBooks()
Dim WS As Worksheet
Dim myfolder As String
Dim a As Single
Dim sht As Worksheet
Dim serRng As Range



Set WS = Sheets.Add

With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    myfolder = .SelectedItems(1) & ""
End With

'Get Search String Range From User
 On Error Resume Next
   Set serRng = Application.InputBox _
       (prompt:="Select or Enter Range With Search Strings" & vbCrLf & vbCrLf & _
                "Click OK When Done" & vbCrLf & vbCrLf & _
                "Click Cancel To Exit", _
                Title:="Search all workbooks in a folder", Type:=8)

 On Error GoTo 0
 
'Exit Sub If Cancel Clicked
 If serRng Is Nothing Then Exit Sub
 
'Do not allow blank cells in Search Range
 If WorksheetFunction.CountA(serRng) <> serRng.Cells.Count Then
  MsgBox "There Are Blank Cells In Your Range." & vbCrLf & vbCrLf & _
         "Blank Search Strings Are Not Allowed." & vbCrLf & vbCrLf & _
         "Please Try Again."
  Exit Sub
 End If

'Setup Worksheet Titles

'WS.Range("A1") = "Search string:" ***I'm not sure what you want here any more
'WS.Range("B1") = Str ***I'm not sure what you want here any more
WS.Range("A2") = "Path:"
WS.Range("B2") = myfolder
WS.Range("A3") = "Workbook"
WS.Range("B3") = "Worksheet"
WS.Range("C3") = "Cell Address"
WS.Range("D3") = "String"
WS.Range("E3") = "Link"

'Search All Sheets In All Workbooks
'(More comments should be added to explain steps)

a = 0

Value = Dir(myfolder)
 Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If Right(Value, 3) = "xls" Or _
           Right(Value, 4) = "xlsx" Or _
           Right(Value, 4) = "xlsm" Then
            On Error Resume Next
            Workbooks.Open Filename:=myfolder & Value, Password:="zzzzzzzzzzzz"
            If Err.Number > 0 Then
                WS.Range("A4").Offset(a, 0).Value = Value
                WS.Range("B4").Offset(a, 0).Value = "Password protected"
                a = a + 1
            Else
                On Error GoTo 0
 
'Search For Each String In Range
             For Each cell In serRng
               For Each sht In ActiveWorkbook.Worksheets
                        Set c = sht.Cells.Find(cell, LookIn:=xlValues, _
                                                     LookAt:=xlPart, _
                                                     SearchOrder:=xlByRows, _
                                                     SearchDirection:=xlNext)
                        If Not c Is Nothing Then
                            firstAddress = c.Address
                            Do
                              WS.Range("A4").Offset(a, 0).Value = Value
                              WS.Range("B4").Offset(a, 0).Value = sht.Name
                              WS.Range("C4").Offset(a, 0).Value = c.Address
                              WS.Range("D4").Offset(a, 0).Value = c.Value
                              WS.Hyperlinks.Add Anchor:=WS.Range("E4").Offset(a, 0), _
                                                Address:=myfolder & Value, _
                                                SubAddress:=sht.Name & "!" & _
                                                c.Address, TextToDisplay:="Link"
                                a = a + 1
                                Set c = sht.Cells.FindNext(c)
                            Loop While Not c Is Nothing And c.Address <> firstAddress
                        End If
                Next sht
             Next
           End If

             Workbooks(Value).Close False
            On Error GoTo 0
        End If
    End If
    Value = Dir
 Loop

Cells.EntireColumn.AutoFit
End Sub

Click Here Before Posting Data or VBA Code —> How To Post Data or Code.