VBA Creer hyperliens d'une feuille à l'autre

actaris51

XLDnaute Occasionnel
Bonjour,

J'ai un petit souci en VBA:
J'ai deux feuilles Excel, de ce type :
Cijoint.fr - Service gratuit de dépôt de fichiers

Je voudrais creer via une macro l'ensemble des hyperliens :
il faut que mes données situés dans mes colonnes de B à F de ma feuille 1 pointent vers la donnée correspondante sur la colonne A de ma feuille 2 (elles ont le meme nom).

Comme dans l'exemple ou les donnees "A" pointes vers la cellule "A1" de ma feuille 2.

Pouvez vous m'aider ?

Merci
 

job75

XLDnaute Barbatruc
Re : VBA Creer hyperliens d'une feuille à l'autre

Bonjour actaris51,

Dans le code de Sheet1 :

Code:
Private Sub CommandButton1_Click()
Dim plage As Range, cel As Range, lig
Set plage = Intersect(Columns("B:F"), Me.UsedRange)
If plage Is Nothing Then Exit Sub
With Sheets("Sheet2")
  For Each cel In plage
    If cel <> "" Then
      lig = Application.Match(cel, .Columns(1), 0)
      If IsNumeric(lig) Then Me.Hyperlinks.Add Anchor:=cel, Address:="", _
        SubAddress:="Sheet2!" & .Cells(lig, 1).Address, TextToDisplay:=cel.Text
    End If
  Next
End With
End Sub

Edit : revu le 1er test

A+
 

Pièces jointes

  • test(1).xls
    30.5 KB · Affichages: 43
  • test(1).xls
    30.5 KB · Affichages: 46
  • test(1).xls
    30.5 KB · Affichages: 47
Dernière édition:

job75

XLDnaute Barbatruc
Re : VBA Creer hyperliens d'une feuille à l'autre

Re,

Quelque chose de plus complet avec une macro Worksheet_Change :

Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Lien Intersect(Target, Columns("B:F"), Me.UsedRange)
End Sub

Private Sub CommandButton1_Click()
Lien Intersect(Columns("B:F"), Me.UsedRange)
End Sub

Sub Lien(plage As Range)
If plage Is Nothing Then Exit Sub
Dim cel As Range, lig
With Sheets("Sheet2")
  For Each cel In plage
    If cel <> "" Then
      lig = Application.Match(cel, .Columns(1), 0)
      If IsNumeric(lig) Then Me.Hyperlinks.Add Anchor:=cel, Address:="", _
        SubAddress:="Sheet2!" & .Cells(lig, 1).Address, TextToDisplay:=cel.Text
    End If
  Next
End With
End Sub

Edit : revu les plages et le 1er test

A+
 

Pièces jointes

  • test(2).xls
    34 KB · Affichages: 52
  • test(2).xls
    34 KB · Affichages: 56
  • test(2).xls
    34 KB · Affichages: 57
Dernière édition:

Discussions similaires

Réponses
4
Affichages
191

Statistiques des forums

Discussions
312 231
Messages
2 086 448
Membres
103 213
dernier inscrit
Poupoule