Hyperlink per VBA ansteuern

Moin zusammen,
ich hab Zelle A1 einen Hyperlink, der folgende Formel enthält:
=IF(DATE(RIGHT(C1;4);MID(C1;4;2);LEFT(C1;2))=TODAY();"";HYPERLINK("#A"&2+MATCH(DATE(RIGHT(C1;4); MID(C1;4;2);LEFT(C1;2));A3:A1000;0);C1))
Zur Erklärung... in Spalte A ist jeder Tag des Jahres 2014 als Datum. Der Hyperlink springt zu der Zeile in dem das Datum steht, das vorher in C1 (mit einem DateTimePicker) eingegeben wurde.
Nun möchte ich, dass per Shortcut das selbe passiert, wie wenn ich manuell auf den Hyperlink draufklicken würde.
Dafür habe ich bereits folgendes in "This Workbook" eingegeben:

Private Sub Workbook_Open()
Application.OnKey "^{q}", "HyperHyper"
End Sub

Im Modul habe ich bereits folgendes probiert:

Sub HyperHyper()
On Error Resume Next
ActiveWorkbook.FollowHyperlink ActiveCell.text
End Sub

Das Ganze funktioniert auch, aber nur wenn ich den friendlyname aus der Formel entferne. D.h wenn dann in A1 das Ergebnis der Formel als Hyperlink steht.
Kann mir evtl. jemand sagen, wie ich das Ganze zum laufen bringe sodass weiterhin der friendlyname da steht. (Activecell.formula habe ich auch schon probiert)
Nebenbei: ich habe nicht viel Ahnung von VBA und habe mir alles was ich bisher habe aus verschiedenen Foren zusammengesucht...
Danke für die Hilfe!!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Function LinkAdresse(Zelle As Range) On Error Resume Next With Zelle.HyperLinks If CBool(.Count) Then If .Item(1).Address = "" Then If InStr(.Item(1).SubAddress, "!") = 0 Then LinkAdresse = "'" & ActiveSheet.Name & "'!" & .Item(1).SubAddress Else: LinkAdresse = .Item(1).SubAddress End If Else: LinkAdresse = .Item(1).Address End If Else: LinkAdresse = CVErr(xlErrNA) 'Anm: Nicht für Fml-HLs! End If End With End Function

…und es fktioniert auch in diesem speziellen, aber nicht in allen Fällen:

Rem Folgt vorhandenem bzw erzeugt neuen HLink lt angegeb Parametern
'   Hinws: Benötigt udF LinkAdresse! Param b.Tasten-KurzRuf unmögl!
'   Vs1.1 -LSr -cd:20141212 -1pub:20141214herber -lUpd:20141214t
Sub FolgeHL(ParamArray ZielAdresse())
Dim LiTrZ$, hlAdr
On Error Resume Next
LiTrZ = Application.International(xlListSeparator)
If Not IsMissing(ZielAdresse) Then
hlAdr = Array(CStr(ZielAdresse(0)), CStr(ZielAdresse(1)))
Else: hlAdr = LinkAdresse(ActiveCell)
End If
If IsError(hlAdr) Then Exit Sub
If IsArray(hlAdr) Then
ActiveWorkbook.FollowHyperlink hlAdr(0), hlAdr(1)
ElseIf IsError(Range(Replace(hlAdr, LiTrZ, ","))) Then
If ActiveCell.HyperLinks(1).Address = "" Then
ActiveWorkbook.FollowHyperlink "#" & hlAdr
Else: ActiveWorkbook.FollowHyperlink hlAdr
End If
Else: Application.Goto Range(Replace(hlAdr, LiTrZ, ","))
End If
End Sub

Rem Liefert ZielAdressen echter u.v.Fml-Hyperlinks in 1er xlBlatt-Zelle
'   Erweiterung d.TrivialVariante* f.echte ExtHLinks auf div IntHLinks;
'   nur f.A1-BezugsNotation! (*lt Quelle: w³.j-hennekes.de/1478886.htm)
'   Vs1.1 -LSr -cd:20141212 -1pub:(1.0)20141213herber -lUpd:20141214t
Function LinkAdresse(Zelle As Range)
Dim klDif(1) As Long, kp As Long, hlAdr
On Error Resume Next
With Zelle.HyperLinks
If CBool(.Count) Then
If .Item(1).Address = "" Then
LinkAdresse = .Item(1).SubAddress
ElseIf .Item(1).SubAddress  "" Then
With .Item(1)
LinkAdresse = Array(.Address, .SubAddress)
End With
Else: LinkAdresse = .Item(1).Address
End If
ElseIf Zelle.HasFormula Then
hlAdr = Zelle.Formula
If CBool(InStr(hlAdr, "HYPERLINK(")) Then
hlAdr = Split(hlAdr, "HYPERLINK(")
klDif(0) = Len(Replace(hlAdr(0), ")", ""))
klDif(1) = Len(Replace(hlAdr(0), "(", "")) - 1
For kp = 1 To klDif(0) - klDif(1)
hlAdr(1) = Left(hlAdr(1), InStrRev(hlAdr(1), ")") - 1)
Next kp
If Right(hlAdr(1), 1)  ")" Then _
kp = InStrRev(hlAdr(1), ",") Else kp = 0
If kp > InStrRev(hlAdr(1), ")") Then hlAdr(1) = Left(hlAdr(1), kp - 1)
If CBool(InStr(hlAdr(1), "(") + InStr(hlAdr(1), """#""&")) Then
LinkAdresse = Evaluate(hlAdr(1))
If LinkAdresse = hlAdr(1) Then LinkAdresse = CVErr(xlErrRef)
Else: LinkAdresse = Replace(hlAdr(1), """", "")
End If
If IsError(LinkAdresse) Then
ElseIf Left(LinkAdresse, 1) = "#" Then
LinkAdresse = Mid(LinkAdresse, 2)
End If
Else: LinkAdresse = CVErr(xlErrRef)
End If
Else: LinkAdresse = CVErr(xlErrNA)
End If
End With
End Function

Luc :-?

Sub Test() Dim sFormel$ With Tabelle1.Range("A1") If .HasFormula Then sFormel = .Formula If InStr(sFormel, "HYPERLINK(") > 0 Then sFormel = Extrahiere_HyLink(sFormel) If sFormel <> "" Then sFormel = Replace(sFormel, "#", .Parent.Name & "!") Application.Goto Range(sFormel) End If End If End If End With End Sub Function Extrahiere_HyLink(ByVal strFormel$) As String Dim varTmp, sErg$ On Error Resume Next varTmp = "HYPERLINK(" & Split(strFormel, "HYPERLINK(")(1) strFormel = "" For Each varTmp In Split(varTmp, ")") strFormel = strFormel & varTmp & ")" sErg = Evaluate(strFormel & ")") If sErg <> "" Then Exit For Next varTmp Extrahiere_HyLink = sErg End Function

Beliebteste Forumthreads (12 Monate)

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread