XL 2013 bouton sélection cellule et hyperlink

Bnj · 15 Mai 2017

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 · 29 Juillet 2017

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.

VB:

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.

VB:

'#
'# 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

VB:

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

Code:

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 · 29 Juillet 2017

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 · 29 Juillet 2017

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.

Code:

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

XL 2013 bouton sélection cellule et hyperlink

Bnj

XLDnaute Occasionnel

STephane

XLDnaute Occasionnel

zebanx

XLDnaute Accro

Pièces jointes

STephane

XLDnaute Occasionnel

Pièces jointes

Discussions similaires