XL 2013 bouton sélection cellule et hyperlink

[Bnj]

bosnoir à tous

j'ai un soucis.
Je n'arrive pas à faire en sorte que lorsque je clique sur un bouton de commande, cela sélectionne la cellule et lance le lien hyperlink créé dans cette cellule grâce à la formule : =LIEN_HYPERTEXTE(données!H2;CONCATENER(données!G2&" "&données!A2&"/"&données!B2&"/"&données!C2&"/"&données!D2&"/"&données!E2))


voici la macro que j'ai essayé :


Sub accèslien()
'
' accèslien Macro
'

'
Range("M43:U43").Hyperlinks(1).Follow
End Sub

 

[STephane]

Bonjour

'# Récupérer l'adresse web précisée dans une formule n'est pas si simple.
'# Ce lien n'est pas manipulable en tant que tel via le langage VBA.

Dim HL As Hyperlinks
Set HL = Range("A1").Hyperlinks '-> fonctionne avec de vrais liens
Set HL = Range("A2").Hyperlinks '-> plante si formule

'#
'# Analyser la formule pour récupérer l'argument adresse de la fonction de calcul LIEN_HYPERTEXTE est une possibilité. Pour la lecture des arguments, j'utilise ci-dessous la fonction ARG (récupérée de je ne sais plus où), et construis le reste.

'#
'# La procédure exemple suit le lien hypertexte stipulé dans la formule de la cellule E4.
[code=VB]
Sub HL_FollowIfFormula()
'MsgBox HL_Path(Range("E4"), RemoveQuotes:=True)
ActiveWorkbook.FollowHyperlink Address:=HL_Path(Range("E4"), True), NewWindow:=True
End Sub

Function HL_Path(rg As Range, RemoveQuotes As Boolean)
'# RemoveQuotes allows removing 1st leading and trailing quotes a string
Dim sArgument As String, sTEMP1 As String
HL_Path = ARG(rg, 1)
If RemoveQuotes Then
    sTEMP1 = HL_Path
    sTEMP1 = Mid(sTEMP1, 2)
    HL_Path = left(sTEMP1, Len(sTEMP1) - 1)
End If
End Function

Private Function ARG$(cel As Range, ordre%)
'# Argument
Dim Txt As String
Dim n As Integer
Dim f As String
Dim Deb As Long
Dim Fin As Long
Dim i As Long
Dim ng!

f = cel.Formula
If IsEmpty(cel) Then Exit Function
f = Mid(f, InStr(f, "(") + 1, Len(f) - InStr(f, "(") - 1) & ","
Deb = 1
Fin = Len(f)

For i = 1 To Fin
    If Mid(f, i, 1) = "," Then
        Txt = Mid(f, Deb, i - Deb)
        ng = (Len(Txt) - Len(Replace(Txt, """", ""))) / 2
        If ng = Int(ng) And Len(Replace(Txt, "(", "")) = Len(Replace(Txt, ")", "")) Then
            n = n + 1
            If n = ordre Then ARG = Txt: Exit Function
            Deb = i + 1
        End If
    End If
Next
End Function

HTH

 

[zebanx]

Bonjour Bnj et Stéphane,

J'utilise pour un "lien" découpé un indirect. Mais ça pourrait fonctionner aussi avec le lien hypertexte.

Cdlt
thierry

 

[STephane]

Bonjour

Il faudrait à ce moment là évaluer cet argument, ce qui permet d'ailleurs d'éviter la manipulation des guillemets.

La fonction HL_PATH lit juste le premier argument de la fonction (sans contrôler que la fonction en question est LIEN_HYPERTEXTE. A noter également, dans l'état actuel de cette fonction, le vrai "lien hypertexte" prévaut dans l'éventualité où une cellule possède à la fois une fonction, à la fois un vrai lien hypertexte.

Sub HL_FollowIfFormula()
MsgBox HL_Path(Range("C3")) '# hyperlink formula
MsgBox HL_Path(Range("B19"))             '# hyperlink formula with indirect
Stop
Dim rgHyperlink As Range
Dim sHyperlink As String
Set rgHyperlink = Range("B19")
sHyperlink = HL_Path(rgHyperlink)
ActiveWorkbook.FollowHyperlink Address:=sHyperlink, NewWindow:=True
End Sub
Function HL_Path(rg As Range)
Dim sArgument As String, sTEMP1 As String

'# Range with real hyperlinks
If rg.Hyperlinks.Count > 0 Then HL_Path = rg.Hyperlinks(1).Address: Exit Function

'# Get 1st argument of formula and evaluate
'#  if 1st argument contains a function, Excel returns its value
'#  if 1st argument is a string, Excel returns string without quotes
HL_Path = ARG(rg, 1)        '# Read 1st argument
HL_Path = Evaluate(HL_Path) '# Evaluate argument
End Function
Function ARG$(cel As Range, ordre%)

Dim f As String, Deb As Long, Fin As Long, i As Long, Txt As String, ng!, n%

f = cel.Formula
If IsEmpty(cel) Then Exit Function
f = Mid(f, InStr(f, "(") + 1, Len(f) - InStr(f, "(") - 1) & ","
Deb = 1
Fin = Len(f)
For i = 1 To Fin
  If Mid(f, i, 1) = "," Then
    Txt = Mid(f, Deb, i - Deb)
    ng = (Len(Txt) - Len(Replace(Txt, """", ""))) / 2
    If ng = Int(ng) And Len(Replace(Txt, "(", "")) = Len(Replace(Txt, ")", "")) Then
      n = n + 1
      If n = ordre Then ARG = Txt: Exit Function
      Deb = i + 1
    End If
  End If
Next
End Function