Option Compare Text 
Option Explicit 
 
Private Const BIF_RETURNONLYFSDIRS As Long = &H1 
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2 
Private Const BIF_RETURNFSANCESTORS As Long = &H8 
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000 
Private Const BIF_BROWSEFORPRINTER As Long = &H2000 
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000 
Private Const MAX_PATH As Long = 260 
 
Type BrowseInfo 
    hOwner As Long 
    pidlRoot As Long 
    pszDisplayName As String 
    lpszINSTRUCTIONS As String 
    ulFlags As Long 
    lpfn As Long 
    lParam As Long 
    iImage As Long 
End Type 
 
Type SHFILEOPSTRUCT 
    hwnd As Long 
    wFunc As Long 
    pFrom As String 
    pTo As String 
    fFlags As Integer 
    fAnyOperationsAborted As Boolean 
    hNameMappings As Long 
    lpszProgressTitle As String 
End Type 
 
Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _ 
ByVal pidl As Long, _ 
ByVal pszBuffer As String) As Long 
Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _ 
lpBrowseInfo As BrowseInfo) As Long 
 
Function BrowseFolder(Optional Caption As String = "") As String 
     
    Dim BrowseInfo As BrowseInfo 
    Dim FolderName As String 
    Dim ID As Long 
    Dim Res As Long 
     
    With BrowseInfo 
        .hOwner = 0 
        .pidlRoot = 0 
        .pszDisplayName = String$(MAX_PATH, vbNullChar) 
        .lpszINSTRUCTIONS = Caption 
        .ulFlags = BIF_RETURNONLYFSDIRS 
        .lpfn = 0 
    End With 
    FolderName = String$(MAX_PATH, vbNullChar) 
    ID = SHBrowseForFolderA(BrowseInfo) 
    If ID Then 
        Res = SHGetPathFromIDListA(ID, FolderName) 
        If Res Then 
            BrowseFolder = Left$(FolderName, InStr(FolderName, _ 
            vbNullChar) - 1) 
        End If 
    End If 
     
End Function 
 
Sub FindAll() 
     
    Dim WB              As Workbook 
    Dim WS              As Worksheet 
    Dim Cell            As Range 
    Dim Prompt          As String 
    Dim Title           As String 
    Dim Search          As String 
    Dim FindCell()      As String 
    Dim FindSheet()     As String 
    Dim FindWorkBook()  As String 
    Dim FindPath()      As String 
    Dim FindText()      As String 
    Dim Counter         As Long 
    Dim FirstAddress    As String 
    Dim Path            As String 
    Dim MyResponse      As VbMsgBoxResult 
    Dim FileName        As String 
     
     '*** Get folder from user ***
    Prompt = "Select the folder with the files that you want to search through." & _ 
    vbNewLine & vbNewLine & "Note: Subfolders will not be searched through." 
    Title = "Folder Selection" 
    MsgBox Prompt, vbInformation, Title 
     
     '*** This code works with XP only and is also used to pick a folder ***
     'Application.FileDialog(msoFileDialogFolderPicker).Show
     'Path = CurDir
     
    Path = BrowseFolder("Select A Folder") 
    If Path = "" Then 
        Prompt = "You didn't select a folder. The procedure has been canceled." 
        Title = "Procedure Canceled" 
        MsgBox Prompt, vbCritical, Title 
GoTo Canceled: 
    End If 
     
    Prompt = "What do you want to search for in the folder: " & vbNewLine & vbNewLine & Path 
    Title = "Search Criteria Input" 
    Search = InputBox(Prompt, Title) 
    If Search = "" Then 
        GoTo Canceled 
    End If 
     
     '*** Confirm the procedure before continuing ***
    Prompt = "Are you sure that you want to search all the files in the folder:" & _ 
    vbCrLf & Path & " for " & """" & Search & """" & "?" 
    Title = "Confirm Procedure" 
    MyResponse = MsgBox(Prompt, vbQuestion + vbYesNo, Title) 
    If MyResponse = vbNo Then 
GoTo Canceled: 
    End If 
     
    Application.DisplayAlerts = False 
    Application.ScreenUpdating = False 
     
     '*** Loop through all Excel workbooks and search each of them for the specified criteria***
    FileName = Dir(Path & "\*.xls", vbNormal) 
    Do Until FileName = "" 
        On Error Resume Next 
        Set WB = Workbooks.Open(FileName:=Path & "\" & FileName, ReadOnly:=True, Password:="DRJWasHere") 
        If Err = 0 Then 
            On Error GoTo 0 
            For Each WS In WB.Worksheets 
                With WB.Sheets(WS.Name).Cells 
                    Set Cell = .Find(What:=Search, LookIn:=xlValues, LookAt:=xlPart, _ 
                    MatchCase:=False, SearchOrder:=xlByColumns) 
                    If Not Cell Is Nothing Then 
                        FirstAddress = Cell.Address 
                        Do 
                            Counter = Counter + 1 
                            ReDim Preserve FindCell(1 To Counter) 
                            ReDim Preserve FindSheet(1 To Counter) 
                            ReDim Preserve FindWorkBook(1 To Counter) 
                            ReDim Preserve FindPath(1 To Counter) 
                            ReDim Preserve FindText(1 To Counter) 
                            FindCell(Counter) = Cell.Address(False, False) 
                            FindText(Counter) = Cell.Text 
                            FindSheet(Counter) = WS.Name 
                            FindWorkBook(Counter) = WB.Name 
                            FindPath(Counter) = WB.FullName 
                            Set Cell = .FindNext(Cell) 
                        Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress 
                    End If 
                End With 
            Next 
        End If 
        On Error GoTo 0 
        WB.Close False 
        FileName = Dir() 
    Loop 
    Prompt = "Occurrences of " & """" & Search & """" 
    If Counter = 0 Then 
        MsgBox Search & " was not found.", vbInformation, "Zero Results For Search" 
        Exit Sub 
    End If 
    Workbooks.Add 
    Range("A1").Value = Prompt 
    Range("A1:D1").Merge 
    Range("A1:D2").Font.Bold = True 
    Range("A2").Value = "Workbook Name" 
    Range("B2").Value = "Sheet Name" 
    Range("C2").Value = "Cell Address" 
    Range("D2").Value = "Cell Text" 
    Range("A1:D2").HorizontalAlignment = xlCenter 
    Range("A:A").ColumnWidth = 40 
    Range("B:D").ColumnWidth = 25 
    For Counter = 1 To UBound(FindCell) 
        ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _ 
        Address:=FindPath(Counter) & "#" & FindSheet(Counter) & "!" & FindCell(Counter), _ 
        TextToDisplay:=Left(FindWorkBook(Counter), Len(FindWorkBook(Counter)) - 4) 
        Range("B" & Counter + 2).Value = FindSheet(Counter) 
        Range("C" & Counter + 2).Value = FindCell(Counter) 
        Range("D" & Counter + 2).Value = FindText(Counter) 
    Next Counter 
     
Canceled: 
     
    Set WB = Nothing 
    Set WS = Nothing 
    Set Cell = Nothing 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
     
End Sub