Sub www()
     Dim c As Range, f$, sh As Worksheet, r As Range, s$
     Application.FindFormat.Clear
     Application.FindFormat.Font.ColorIndex = 3
     For Each sh In ThisWorkbook.Worksheets
         If sh.Name <> "Лист1" Then
             With sh.UsedRange
                 Set c = .Find("*", LookIn:=xlValues, SearchFormat:=True)
                 If Not c Is Nothing Then

                     s = c.Address(external:=-1)
                     f = s
                     Do
                         Set r = Sheets("Лист1").[a65536].End(xlUp)(2)
                         Sheets("Лист1").Hyperlinks.Add Anchor:=r, Address:="", SubAddress:=f
                         r.Hyperlinks(1).TextToDisplay = c.Text
                         Set c = .Find("*", c, LookIn:=xlValues, SearchFormat:=True)
                         f = c.Address(external:=-1)
                     Loop While Not c Is Nothing And f <> s
                 End If
             End With
         End If
     Next
End Sub