Copier liens hypertextes VBA

Bonjour à tous,

Je viens vers vous car je suis dans une impasse malgré mes recherches sur cette mine d'or ce forum.

J'ai un fichier excel avec quelques 400 feuilles. Chaque feuille correspond à un fournisseur, et dans chaque feuille fournisseur, en cellule B2, il y a un lien hypertexte qui mène vers le site Internet de celui ci.

J'ai une feuille "recap" et dans cette feuille, la liste de tous mes fournisseurs. J'aimerais pouvoir copier coller le lien hypertexte de chaque fournisseur, en face de son nom dans la liste (feuille "recap"). Le niveau suivant serait d'attribuer le lien hypertexte directement au nom du fournisseur.

Ci joint un fichier exemple. Dans celui ci les feuilles fournisseurs sont les feuilles "test1, test2,..." et en B2 de chaque feuille, les liens que je voudrais retrouver dans ma feuille "RECAP".

Une solution qui marche une fois seulement me convient.

Bonne soirée et merci de m'avoir lu.

Bonjour

Voilà une solution :

Sub Liens()
Dim BD As Worksheet
Dim i  As Integer, DernLig As Integer, PremLig As Integer
Dim ListNom As String
Dim Feuilles As Object
Dim TBL As Variant

Set BD = ThisWorkbook.Worksheets("RECAP")
PremLig = 2
DernLig = BD.Range("B" & BD.Rows.Count).End(xlUp).Row

For i = PremLig To DernLig
    If ListNom = "" Then
        ListNom = BD.Cells(i, 2)
    Else
        ListNom = ListNom & "\" & BD.Cells(i, 2)
    End If
Next i

TBL = Split(ListNom, "\")
For Each Feuilles In ThisWorkbook.Worksheets
    For i = LBound(TBL) To UBound(TBL)
        If Feuilles.Name = TBL(i) Then BD.Hyperlinks.Add anchor:=BD.Cells(i + 2, 3), Address:=ThisWorkbook.Worksheets(Feuilles.Name).Range("B2")
    Next i
Next Feuilles
End Sub

Bonjour Kirchkov, GGautier,

En retour ton fichier modifié, voir bouton sur la feuille RECAP.

La macro est réalisée avec cette feuille en 1ière position.

Sub HypText()
For W = 1 To Worksheets.Count
If Worksheets(W).Name <> "RECAP" Then
With Worksheets("RECAP")
.Hyperlinks.Add Anchor:=.Cells(W, 3), Address:=Worksheets(W).Range("B2").Hyperlinks(1).Address
End With
End If
Next W
End Sub

Bons tests, bonne continuation

Bonjour à vous,

Tout d'abord merci de votre réactivité !!!!!

GGautier, je viens de tester ton code, celui me renvoi bien ma cellule avec un lien mais celui ci n’amène à rien et je renvoi quand je clique dessus "impossible de trouver le fichier spécifié".

X Celus, la macro fonctionne super bien sur mon fichier test mais quand je l'applique à mon vrai fichier, il y a une erreur au niveau de la ligne 6 "l'indice n'appartient pas à la selection.

Sub HypText()

Dim HL As Hyperlink

For W = 1 To Worksheets.Count

If Worksheets(W).Name <> "LISTE GMI" Then

With Worksheets("LISTE GMI")

.Hyperlinks.Add anchor:=.Cells(W, 3), Address:=Worksheets(W).Range("B3").Hyperlinks(1).Address

End With

End If

Next W

End Sub

Dans mon vrai fichier les feuilles sont mélangés et pas forcément dans le même ordre que dans la liste que l'on retrouve en "RECAP".

Je dois oublier de modifier quelque chose mais je ne vois pas quoi.

Je remets un fichier exemple que j'ai modifié pour qu'il corresponde mieux a mon fichier réel.

Merci encore

Bonjour Kirchkov, le Forum,

Et merci pour ton appréciation.

Selon ta dernière remarque, j'ai modifié la macro. Les noms d'onglets doivent correspondre aux noms inscrits en feuille Récap.

Et pour les feuilles "vides", c'est à dire leur cellule B2 doit être vide. Les autres cellules peuvent contenir des données.

Bons tests, bonne continuation.