Option Explicit


'---- Hyperlink in Zelle A1 einfügen ------------------------
Sub AddHyperlinkToCell()
  With ActiveSheet
    .Range("A1").Clear
    .Hyperlinks.Add Anchor:=.Range("A1"), _
          Address:="http://www.vb-fun.de/", _
          TextToDisplay:="VB-fun-Startseite"
  End With
End Sub


'---- Zell-Adressen der Zellen mit Hyperlinks ermitteln -----
Sub GetCellsWithHyperlinks()
  Dim hypLink As Hyperlink

  For Each hypLink In ActiveSheet.Hyperlinks
    MsgBox hypLink.Range.Value & "  in Zelle  " & _
        hypLink.Range.Address, vbOKOnly, Title:="Hyperlink..."
  Next hypLink
End Sub


'---- Alle Hyperlinks auf dem Tabellenblatt selektieren -----
Sub SelectAllHyperlinks()
  Dim hypLink   As Hyperlink
  Dim nCnt      As Integer
  Dim rngLinks  As Range

  nCnt = 1
  For Each hypLink In ActiveSheet.Hyperlinks
    If nCnt = 1 Then
      Set rngLinks = hypLink.Range
      nCnt = 0
    Else
      Set rngLinks = Application.Union(rngLinks, hypLink.Range)
    End If
  Next hypLink

  If Not rngLinks Is Nothing Then
    rngLinks.Select
  End If
  Set rngLinks = Nothing
End Sub


'---- Alle Hyperlinks auf dem Tabellenblatt deaktivieren ----
Sub DeactivateAllHyperlinks()
  Dim hypLink As Hyperlink

  For Each hypLink In ActiveSheet.Hyperlinks
    hypLink.Delete          'Hyperlink deaktivieren
    'hypLink.Range.Clear    'Hyperlink löschen
                            '(Formatierung wird auch gelöscht)
    'hypLink.Range = ""     'Hyperlink löschen
                            '(Zell-Formatierung bleibt erhalten)
  Next hypLink
End Sub


'---- Alle Zellen mit "www." als "Hyperlink" aktivieren -----
Sub ActivateHyperlinks()
  Dim rngCell As Range

  With ActiveSheet
    For Each rngCell In .UsedRange
      If InStr(rngCell.Value, "www.") <> 0 Then
        .Hyperlinks.Add Anchor:=.Range(rngCell.Address), _
                  Address:=rngCell.Value
      End If
    Next rngCell
  End With
End Sub


'---- Hyperlink folgen, wenn "vb-fun" vorkommt -------------
Sub FollowHyperlink()
  Dim hypLink As Hyperlink
  Dim blnFound As Boolean

  For Each hypLink In ActiveSheet.Hyperlinks
    If InStr(hypLink.Name, "vb-fun") <> 0 Then
      blnFound = True
      Exit For
    End If
  Next
  If blnFound Then hypLink.Follow NewWindow:=True
End Sub