'In the SearchWord sheet
Option Explicit 
 
Private Sub Worksheet_Change(ByVal Target As Range) 
    If Target.Address = "$B$1" Then 
        Application.Run "SearchWord.xla!FindAll", Target.Text, "False" 
        Cells(1, 2).Select 
    End If 
End Sub 
 
 'In ThisWorkbook of the Add-In
Option Explicit 
Private Sub Workbook_AddinInstall() 
    On Error Resume Next 
    Application.CommandBars("Tools").Controls("Search &word").Delete 
    On Error GoTo 0 
    With Application.CommandBars("Tools").Controls.Add 
        .Caption = "Search &word" 
        .Tag = "Search word" 
        .OnAction = "'" & ThisWorkbook.Name & "'!Search.DoFindAll" 
    End With 
    MsgBox "'Search word' option added to Tools menu" 
End Sub 
 
Private Sub Workbook_AddinUninstall() 
    On Error Resume Next 
    Application.CommandBars("Tools").Controls("Search &word").Delete 
End Sub 
 
 'In a module of the Add-In
Option Compare Text 
Option Explicit 
 
Public Sub DoFindAll() 
    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 
     
    If Search = "" Then 
        Prompt = "What do you want to search for in the worbook: " & _ 
        vbNewLine & vbNewLine & Path 
        Title = "Search Criteria Input" 
        Search = InputBox(Prompt, Title, "Enter search term") 
        If Search = "" Then 
            GoTo Cancelled 
        End If 
    End If 
     
    Application.EnableEvents = False 
    Application.DisplayAlerts = False 
    Application.ScreenUpdating = False 
     
    On Error GoTo Cancelled 
     
    Set WB = ActiveWorkbook 
    For Each WS In WB.Worksheets 
        If WS.Name <> "SearchWord" Then 
             'Search whole sheet
             'With WB.Sheets(WS.Name).Cells
             '***********************************
             'Alternative to search single column
            With WB.Sheets(WS.Name).Range("B:B") 
                 '***********************************
                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 
     
     'If no result found, reset properties and exit sub
    If Counter = 0 Then 
        MsgBox Search & " was not found.", vbInformation, "Zero Results For Search" 
         'Clear old results if required
         'Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents
         '**********************************
        GoTo Cancelled 
    End If 
     
     'Add SearchWord sheet if not present
    On Error Resume Next 
    Sheets("SearchWord").Select 
    If Err <> 0 Then 
        ThisWorkbook.Sheets("SearchWord").Copy Before:=ActiveWorkbook.Worksheets(1) 
    End If 
     
    On Error GoTo Cancelled 
     
     'Clear old data and then format results page as required
    Range("A3", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell)).ClearContents 
    Range("A1:B1").Interior.ColorIndex = 6 
    Range("A1").Value = "Occurences of:" 
    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 
    With Columns("A:A") 
        .ColumnWidth = 14 
        .VerticalAlignment = xlTop 
    End With 
    With Columns("B:B") 
        .ColumnWidth = 50 
        .VerticalAlignment = xlCenter 
        .WrapText = True 
    End With 
     
     'Add hyperlinks and results to spreadsheet
    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) 
         
         'Add text from offset columns; probably not
         'appropriate with whole sheet search
        Range("C" & Counter + 2).Value = _ 
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, 1) 
        Range("D" & Counter + 2).Value = _ 
        Sheets(FindSheet(Counter)).Range(FindCell(Counter)).Offset(0, 2) 
         '*********************************************
    Next Counter 
     
     'Find search term on results page and colour text
    ColourText 
     
Cancelled: 
     
    Set WB = Nothing 
    Set WS = Nothing 
    Set Cell = Nothing 
    Application.DisplayAlerts = True 
    Application.ScreenUpdating = True 
    Application.EnableEvents = True 
     
End Sub 
 
Sub ColourText() 
    Dim Strt As Long, x As Long, i As Long 
    Columns("B:B").Characters.Font.ColorIndex = xlAutomatic 
    For i = 3 To Range("B" & Rows.Count).End(xlUp).Row 
        x = 1 
        Do 
            Strt = InStr(x, Range("B" & i), [B1], 1) 
            If Strt = 0 Then Exit Do 
            Range("B" & i).Characters(Start:=Strt, _ 
            Length:=Len([B1])).Font.ColorIndex = 7 
            x = Strt + 1 
        Loop 
    Next 
End Sub