Sub Макрос()

    Dim shTOC As Worksheet, sh As Worksheet
    Dim arrTOC(), lr As Long, iTOC As Long, iSh As Long, r As Long
    
    Application.ScreenUpdating = False
    
    Set shTOC = Worksheets("Содержание")
    
    lr = shTOC.Columns("B").Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Row
    arrTOC() = shTOC.Range("B1:B" & lr).Value

    For iTOC = 1 To UBound(arrTOC)
    
        If arrTOC(iTOC, 1) = Empty Then
            GoTo metka
        End If
        
        For iSh = 2 To Worksheets.Count
            Set sh = Worksheets(iSh)
            If WorksheetFunction.CountIf(sh.Columns("B"), arrTOC(iTOC, 1)) <> 0 Then
                r = WorksheetFunction.Match(arrTOC(iTOC, 1), sh.Columns("B"), 0)
                shTOC.Hyperlinks.Add Anchor:=shTOC.Cells(iTOC, "B"), Address:="", _
                    SubAddress:="'" & sh.Name & "'!" & sh.Cells(r, "B").Address, _
                    TextToDisplay:=arrTOC(iTOC, 1)
                Exit For
            End If
        Next

metka:
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation

End Sub