Récupérer le lien hypertexte qui se trouve dans une cellule

Bonjour,

Comment récupérer en VBA ou fonction le lien hypertexte qui se trouve dans les cellules de la colonne A, pour le placer en H?

ou mieux, ouvrir le lien quand on affiche la cellule A ( voir usf en cliquant sur recherche)

merci

Bonsoir,

une proposition de modification / ajout de code sur votre USF :

Option Compare Text

Private Sub UserForm_Initialize()
    TextBox1.SetFocus
End Sub

Private Sub TextBox1_Change()
    Application.ScreenUpdating = False
    Range("A2:A35000").Interior.ColorIndex = 2
    ListBox1.Clear
    If TextBox1 <> "" Then
        For ligne = 2 To 35000
            If Sheets("ville").Cells(ligne, 1) Like "*" & TextBox1 & "*" Then
                Sheets("ville").Cells(ligne, 1).Interior.ColorIndex = 43
                TextBox2.Value = Sheets("ville").Cells(ligne, 8)
                ListBox1.AddItem Sheets("ville").Cells(ligne, 1)
                ' ajout du lien complet en deuxième colonne qui pourra être masquée
                ListBox1.List(ListBox1.ListCount - 1, 1) = Sheets("ville").Cells(ligne, 8)
            End If
        Next
    End If
End Sub

Private Sub TextBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    ThisWorkbook.FollowHyperlink Address:=Me.TextBox2.Text
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    ' envoie du lien qui se trouve en deuxième colonne de la ligne cliquée
    ThisWorkbook.FollowHyperlink Address:=Me.ListBox1.List(ligne, 1)
End Sub

Il faut aussi passer la propriété de la ListBox1 "ColumnCount" à 2

@ bientôt

LouReeD

Bonjour,

Je me suis mal exprimé

La colonne H je l'ai rempli en cliquant droit sur la ville.

je ne sais pas comment récupérer sans passé par cette méthode.

j'ai 35000 villes

Si je supprime la colonne H qui n'existe normalement pas, vôtre macro ne fonctionne pas

Ou j'ai oublié quelque chose

j'ai bien mis

"ColumnCount" à 2

Il faut aussi passer la propriété de la ListBox1 "ColumnCount" à 2

et pourquoi?

J'ai trouvé vevi:

Sub Extracthyperlinks()
'Updateby Extendoffice
Dim Rng As Range
Dim WorkRng As Range
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
For Each Rng In WorkRng
    If Rng.Hyperlinks.Count > 0 Then
        Rng.Value = Rng.Hyperlinks.Item(1).Address
    End If
Next
End Sub

il faut que je le place sur une colonne différente de A

Merci