Option Compare Text 
Option Explicit 
 
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long 
 
Const SM_CXSCREEN = 0 
 
 'Returns screen size to set display column width
Private Function ScreenWidth() 
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN) 
End Function 
 
Sub DoFindAll() 
     'Arguments required for initial use in a workbook
    FindAll "", "True" 
End Sub 
 
 
Public Sub FindAll(Search As String, Reset As Boolean) 
     
    Dim WB              As Workbook 
    Dim WS              As Worksheet 
    Dim Cell            As Range 
    Dim Prompt          As String 
    Dim Title           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 
     
    If Search = "" Then 
        Prompt = "What do you want to search for in the worbook: " & vbNewLine & vbNewLine & Path 
        Title = "Search Criteria Input" 
         'Delete default search term if required
        Search = InputBox(Prompt, Title, "Enter search term") 
        If Search = "" Then 
            GoTo Canceled 
        End If 
    End If 
     
    Application.DisplayAlerts = False 
    Application.ScreenUpdating = False 
     
     'Save found addresses and text into arrays
    On Error Resume Next 
    Set WB = ActiveWorkbook 
    If Err = 0 Then 
        On Error GoTo 0 
        For Each WS In WB.Worksheets 
             'Omit results page from search
            If WS.Name <> "FindWord" Then 
                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 
            End If 
        Next 
    End If 
    On Error GoTo 0 
     'Response if no text found
    If Counter = 0 Then 
        MsgBox Search & " was not found.", vbInformation, "Zero Results For Search" 
        Exit Sub 
    End If 
     
     'Create FindWord sheet in does not exist
    On Error Resume Next 
    Sheets("FindWord").Select 
    If Err <> 0 Then 
        Debug.Print Err 
         'error occured so clear it
        Err.Clear 
        Sheets.Add.Name = "FindWord" 
        Sheets("FindWord").Move After:=Sheets(Sheets.Count) 
         'Run macro to add code to ThisWorkbook
        AddSheetCode 
    End If 
     'Write hyperlinks and texts to FindWord
    Range("A3:B65536").ClearContents 
    Range("A1:B1").Interior.ColorIndex = 6 
    Range("A1").Value = "Occurences of:" 
     'Reset prevents looping of code when sheet changes
    If Reset = True Then Range("B1").Value = Search 
    Range("A1:D2").Font.Bold = True 
    Range("A2").Value = "Location" 
    Range("B2").Value = "Cell Text" 
    Range("A1:B1").HorizontalAlignment = xlLeft 
    Range("A2:B2").HorizontalAlignment = xlCenter 
     'Adjust column width to suit display
    Range("A:A").ColumnWidth = ScreenWidth / 60 
    Range("B:B").ColumnWidth = ScreenWidth / 10 
    For Counter = 1 To UBound(FindCell) 
        ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _ 
        Address:="", SubAddress:=FindSheet(Counter) & "!" & FindCell(Counter), _ 
        TextToDisplay:=FindSheet(Counter) & "!" & FindCell(Counter) 
        Range("B" & Counter + 2).Value = FindText(Counter) 
    Next Counter 
    Range("B1").Select 
Canceled: 
     
    Set WB = Nothing 
    Set WS = Nothing 
    Set Cell = Nothing 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
     
End Sub 
 
 
Sub AddSheetCode() 
     'Thanks to Dragontooth
    Dim strCode As String 
    Dim FWord As String 
    Dim WB As Workbook 
    Dim Sh 
    Dim I As Integer 
    Set WB = ActiveWorkbook 
     
     'Line to be inserted instead of 4th line below if code in Personal.xls
     '& "Application.Run (" & Chr(34) & "Personal.xls!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
     'Optional 4th line if code in workbook
     '& "FindAll Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
     
    strCode = "Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)" & vbCr _ 
    & "If Sh.Name = " & Chr(34) & "FindWord" & Chr(34) & " Then" & vbCr _ 
    & "If Target.Address = " & Chr(34) & "$B$1" & Chr(34) & " Then" & vbCr _ 
    & "Application.Run (" & Chr(34) & "Personal.xls!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _ 
    & "Cells(1,2).Select" & vbCr _ 
    & "End if" & vbCr _ 
    & "End if" & vbCr _ 
    & "End Sub" 
     'Debug.Print strCode
     
     'Write code to ThisWorkbook module
    FWord = "ThisWorkbook" 
    For I = 1 To WB.VBProject.VBComponents.Count 
        If WB.VBProject.VBComponents.Item(I).Name = FWord Then 
            Exit For 
        End If 
    Next 
    If Not WB.VBProject.VBComponents.Item(I).CodeModule Is Nothing Then 
        If Not WB.VBProject.VBComponents.Item(I).CodeModule.Find("Workbook_SheetChange", 1, 1, 100, 100) Then 
            WB.VBProject.VBComponents.Item(I).CodeModule.AddFromString (strCode) 
        End If 
    End If 
    Set WB = Nothing 
     
End Sub