Search entire workbook with control button

hi try this

Sub CommandButton1_Click()
     
    Dim ThisAddress$, Found, FirstAddress
    Dim Lost$, N&, NextSheet&
    Dim CurrentArea As Range, SelectedRegion As Range
    Dim Reply As VbMsgBoxResult
    Dim FirstSheet As Worksheet
    Dim Ws As Worksheet
    Dim Wks As Worksheet
    Dim Sht As Worksheet
     
    Set FirstSheet = ActiveSheet '< bookmark start sheet
    Lost = InputBox(prompt:="Type in the   book details you are looking for!", _
    Title:=" Find what?", Default:="*")
    If Lost = Empty Then End
    For Each Ws In Worksheets
        Ws.Select
        With ActiveSheet.Cells
            Set FirstAddress = .Find(What:=Lost, LookIn:=xlValues)
            If FirstAddress Is Nothing Then '< blank sheet
                GoTo NextSheet
            End If
            FirstAddress.Select
             '    Selection.Interior.ColorIndex = 6 '< yellow
             '//colour the 'Lost' font red, cell colour blank
            With Selection
                Set Found = .Find(What:=Lost, LookIn:=xlValues)
                If Not Found Is Nothing Then
                    FirstAddress = Found.Address
                  '  Do
                         '     Found.Interior.ColorIndex = 3 '< red
                         '    Found.Font.Bold = True
                         '   Found.Font.ColorIndex = 2
                         '   Set Found = .FindNext(Found)
                  '   Loop While Not Found Is Nothing And Found. _
                    Address <> FirstAddress
                End If
            End With
            Reply = MsgBox("Is this the " & Lost & " you're looking for?", _
            vbQuestion + vbYesNoCancel)
             '//restore the 'Lost' font and cell colour
            Set Found = .Find(What:=Lost, LookIn:=xlValues)
            If Not Found Is Nothing Then
                FirstAddress = Found.Address
                Do
                     ' Found.Font.Bold = False
                     'Found.Font.ColorIndex = 0
                    Set Found = .FindNext(Found)
                Loop While Not Found Is Nothing And Found. _
                Address <> FirstAddress
            End If
             '//restore the selection colour
             '  Selection.Interior.ColorIndex = xlNone
            Set FirstAddress = .Find(What:=Lost, LookIn:=xlValues)
            If Reply = vbCancel Then End
             '//dont look further
            If Reply = vbYes Then
                Set SelectedRegion = Selection
                 ActiveCell.Interior.ColorIndex = 3
                
GoTo Finish:
            End If
             '//   case=not this one
            ThisAddress = FirstAddress.Address
            Set CurrentArea = Selection
            Do
                If Intersect(CurrentArea, Selection) Is Nothing Then
                     ''  With Selection.Interior
                     '    .ColorIndex = 6
                     '   .Pattern = xlSolid
                     '   End With
                     '//colour the 'Lost' font red, cell colour blank
                    With Selection
                        Set Found = .Find(What:=Lost, LookIn:=xlValues)
                        If Not Found Is Nothing Then
                            FirstAddress = Found.Address
                            Do
                                 '  Found.Interior.ColorIndex = 3
                                 ' Found.Font.Bold = True
                                 'Found.Font.ColorIndex = 2
                                Set Found = .FindNext(Found)
                            Loop While Not Found Is Nothing And Found. _
                            Address <> FirstAddress
                        End If
                    End With
                    Reply = MsgBox("Is this the " & Lost & " you're looking for?", _
                    vbQuestion + vbYesNoCancel, "Current Region")
                     '//restore the 'Lost' font and cell colour
                    Set Found = .Find(What:=Lost, LookIn:=xlValues)
                    If Not Found Is Nothing Then
                        FirstAddress = Found.Address
                       ' Do
                             ' Found.Font.Bold = False
                             ' Found.Font.ColorIndex = 0
                            Set Found = .FindNext(Found)
                     '   Loop While Not Found Is Nothing And Found. _
                        Address <> FirstAddress
                    End If
                     '//restore the selection colour
                     '  Selection.Interior.ColorIndex = xlNone
                    Set FirstAddress = .Find(What:=Lost, _
                    LookIn:=xlValues)
                    If Reply = vbCancel Then End
                    If Reply = vbYes Then
                      '  Set SelectedRegion = Selection
                    ActiveCell.Interior.ColorIndex = 3
                        ' Found.Interior.ColorIndex = 3
                                  Found.Font.Bold = True
                                 Found.Font.ColorIndex = 2
                        
GoTo Finish:
                    End If
                End If
                If CurrentArea Is Nothing Then
                    Set CurrentArea = Selection
                Else
                    Set CurrentArea = Union(CurrentArea, Selection)
                End If
                Set FirstAddress = .FindNext(FirstAddress)
                FirstAddress.Select
            Loop While Not FirstAddress Is Nothing And FirstAddress. _
            Address <> ThisAddress
        End With
NextSheet:
    Next Ws
Finish:
    If Reply = vbYes Then
        Exit Sub
    Else
        FirstSheet.Select
        MsgBox "Search Completed - Sorry, no more " & Lost & "s", _
        vbInformation, "No Region Selected"
    End If
End Sub

steve