lien hypertexte vers source

Version imprimable

Bonjour,

j'ai un petit bout de code (simple et surement mal fait...) qui extrait quelques données d'un onglet pour les coller dans un autre onglet :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub maj()
 
Dim plage As Range, clz As Range
Dim derlige As Long
Sheets("clos").Range("a2:c3000").Clear
Sheets("clos").Range("e2:e3000").Clear
Sheets("FICHIER GAL").Select
  derlige = Range("A65536").End(xlUp).Row
    Set plage = Range("A2:A" & derlige)
Range("f2").Select
Application.ScreenUpdating = False
 
For Each clz In plage
        If ActiveCell.Interior.Color = RGB(127, 127, 127) Then
        If ActiveCell.Offset(0, 2).MergeCells Then
        ActiveCell.Offset(0, -4).Copy
        Sheets("clos").Cells(65535, 5).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
            ActiveCell.Offset(1, 0).Select
            Else
            ActiveCell.Offset(0, -4).Copy
            Sheets("clos").Cells(65535, 1).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
            ActiveCell.Offset(0, 1).Copy
            Sheets("clos").Cells(65535, 2).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
            ActiveCell.Copy
            Sheets("clos").Cells(65535, 3).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
        End If
     End If
        ActiveCell.Offset(1, 0).Select
 Next clz
 Calculate
Application.ScreenUpdating = True
 
End Sub

J'aimerais mettre un lien (hypertexte ?) sur cette ligne

Code:

1
2
ActiveCell.Offset(0, 1).Copy
            Sheets("clos").Cells(65535, 2).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues

pour que sur dans la feuille "clos", en cliquant sur la valeur copiée, cela me ramène sur la feuille "FICHIER GAL" à l'endroit source de cette valeur...

J'ai beau chercher, j'ai du mal à saisir le fonctionnement des liens. Tout ce que j'arrive à faire me mets un lien sur une mauvaise donnée, dans la mauvaise feuille, lien qui ramène au classeur entier :cry:

Merci pour votre aide!!! :help:

Bonjour

Voici un début: met le lien hypertexte qui renvoie vers la feuille Gal et la cellule B15
Code:

1 2 ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _ "'Fichier Gal'!B15", TextToDisplay:="'Fichier Gal'!B15"

03/10/2012, 17h36
zealot37
Bonjour,

merci pour ce début :D

Les liens sont créés mais dans l'onglet "FICHIER GAL", et ce pour chaque valeur que la macro trouve; le lien renvoi toujours dans ce meme onglet à la cellule B15.

J'aimerais que les liens soient créés dans l'ongler "clos" et renvoi, pour chaque valeur de
Code:

1 2 ActiveCell.Offset(0, 1).Copy Sheets("clos").Cells(65535, 2).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
à la cellule correspondante dans "FICHIER GAL"...
J'avoue que je bloque...

Je ne trouve pas de référence qui décrive vraiment les liens et comment les mettre en place.

Est-il possible de créer un lien sur une valeur copiée ou faut-il créer une autre macro pour retraiter les infos ?

En essayant de retraiter de tout, j'obtiens rien de bien valable, mes valeurs reprennent la premiere ligne du FICHIER GAL... :cry:

Re-bonjour,

j'insiste sur mon problème... ou plutôt je persévère :mouarf:

En m'inspirant d'une des (nombreuses) solution de Mercatog http://www.developpez.net/forums/d12...cellule-texte/

J'obtiens :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Sub LienHyp() Dim LastLig As Long Dim Fich As String Dim cel As Range Application.ScreenUpdating = False With Worksheets("clos") 'Dernière ligne remplie de la colonne A LastLig = .Range("A" & .Rows.Count).End(xlUp).Row For Each cel In .Range("B2:B" & LastLig) Fich = Sheets("FICHIER GAL").Range("G:G").Find(cel.Value, LookIn:=xlValues, lookat:=xlWhole) .Hyperlinks.Add Anchor:=.Cells("B2" & LastLig), Address:=Fich, TextToDisplay:=.Cells("B2" & LastLig).Value Next cel End With End Sub
Mais j'ai un débogage sur la ligne du lien hypertexte, encore... :cry:
Une fois de plus si quelqu'un à une idée

J'y suis presque...
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Sub LienHyp() Dim LastLig As Long Dim Fich As String Dim cel As Range Application.ScreenUpdating = False With Worksheets("clos") 'Dernière ligne remplie de la colonne A LastLig = .Range("A" & .Rows.Count).End(xlUp).Row For Each cel In .Range("B2:B" & LastLig) Fich = Sheets("FICHIER GAL").Range("G:G").Find(cel.Value, LookIn:=xlValues, lookat:=xlWhole).Address .Hyperlinks.Add Anchor:=cel, Address:=Fich, TextToDisplay:=CStr(cel.Value) Next cel End With End Sub
Par contre il veut absolument m'ouvrir un fichier qui n'existe pas mais qui a pour nom l'adresse de la cellule à laquelle j'aimerais que le lien me renvoi...:cry:

Comment faire pour qu'il me renvoi à la cellule concernée dans l'onglet concerné sans qu'il veuille m'ouvrir un fichier inexistant ?

Merci

Bonjour,

Change le nom de la feuille pour qu'il ne comporte plus d'espace (FICHIER GAL --> FICHIER_GAL et teste ceci :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
Sub LienHyp()
Dim cel As Range, i As Integer
 
With Worksheets("clos")
    For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
        Set cel = Sheets("FICHIER_GAL").Range("G:G").Find(.Cells(i, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not cel Is Nothing Then
            .Hyperlinks.Add Anchor:=.Cells(i, 2), Address:="", SubAddress:="FICHIER_GAL!" & cel.Address(0, 0), TextToDisplay:=.Cells(i, 2).Value
        End If
    Next
End With
End Sub

05/10/2012, 14h53
zealot37

Bonjour fring

Cela me donne une erreur d'éxécution 5 => Argument ou appel de procédure incorrect pour :

Code:

.Hyperlinks.Add Anchor:=.Cells(i, 2), Address:="", SubAddress:="FICHIER_GAL!" & cel.Address(0, 0), TextToDisplay:=.Cells(i, 2).Value
05/10/2012, 15h21
fring

Ce code a été testé et il fonctionne, pour voir comment tu l'utilises tu dois mettre ton code complet

Désolé :oops:

Voilà tout le code utilisé :)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Sub maj()
 
Dim plage As Range, clz As Range
Dim derlige As Long
Sheets("clos").Range("a2:c3000").Clear
Sheets("clos").Range("e2:e3000").Clear
Sheets("FICHIER_GAL").Select
  derlige = Range("A65536").End(xlUp).Row
    Set plage = Range("A2:A" & derlige)
Range("f2").Select
Application.ScreenUpdating = False
 
For Each clz In plage
    'adress = clz.Value
        If ActiveCell.Interior.Color = RGB(127, 127, 127) Then
        If ActiveCell.Offset(0, 2).MergeCells Then
        ActiveCell.Offset(0, -4).Copy
        Sheets("clos").Cells(65535, 5).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
        'MsgBox " ==>>> " & clz.Address & " Dans plage " & clz.MergeArea.Address
        ActiveCell.Offset(1, 0).Select
            Else
            ActiveCell.Offset(0, -4).Copy
            Sheets("clos").Cells(65535, 1).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
            ActiveCell.Offset(0, 1).Copy
            Sheets("clos").Cells(65535, 2).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
            ActiveCell.Copy
            Sheets("clos").Cells(65535, 3).End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
        End If
     End If
        ActiveCell.Offset(1, 0).Select
 Next clz
 Calculate
 LienHyp
Application.ScreenUpdating = True
 
End Sub
 
 
Private Sub LienHyp()
Dim cel As Range, i As Integer
 
With Worksheets("clos")
    For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row
        Set cel = Sheets("FICHIER_GAL").Range("G:G").Find(.Cells(i, 2).Value, LookIn:=xlValues, lookat:=xlWhole)
        If Not cel Is Nothing Then
            .Hyperlinks.Add Anchor:=.Cells(i, 2), Address:="", SubAddress:="FICHIER_GAL!" & cel.Address(0, 0), TextToDisplay:=.Cells(i, 2).Value
        End If
    Next
End With
End Sub

05/10/2012, 15h49
fring

Là comme ça je ne vois pas ce qui provoque l'erreur, as-tu testé en n'exécutant que la procédure LienHyp ?
05/10/2012, 16h03
zealot37

Oui j'ai bien essayé... mais j'ai toujours la même erreur!!
05/10/2012, 19h23
fring

peux-tu joindre ton fichier ?

Essaies comme ceci

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Sub MAJ()
Dim Plage As Range, Clz As Range, c As Range
Dim DerLige As Long, NewLig As Long
 
Application.ScreenUpdating = False
With Worksheets("clos")
    .Range("A2:C3000").Clear
    .Range("E2:E3000").Clear
 
    With Worksheets("FICHIER_GAL")
        DerLige = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Plage = .Range("A2:A" & DerLige)
    End With
 
    NewLig = 2
    For Each Clz In Plage
        If Clz.Offset(0, 5).Interior.Color = RGB(127, 127, 127) Then
            If Clz.Offset(0, 7).MergeCells Then
                .Range("E" & NewLig).Value = Clz.Offset(0, 1).Value
            Else
                .Range("A" & NewLig).Value = Clz.Offset(0, 1).Value
                .Range("B" & NewLig).Value = Clz.Offset(0, 4).Value
                .Range("C" & NewLig).Value = Clz.Offset(0, 5).Value
                Set c = Plage.Offset(0, 6).Find(.Range("B" & NewLig), LookIn:=xlValues, lookat:=xlWhole)
                If Not c Is Nothing Then
                    .Hyperlinks.Add Anchor:=.Range("B" & NewLig), Address:="", SubAddress:="FICHIER_GAL!" & c.Address(0, 0), TextToDisplay:=CStr(.Range("B" & NewLig).Value)
                    Set c = Nothing
                End If
            End If
            NewLig = NewLig + 1
        End If
    Next Clz
    Set Plage = Nothing
End With
End Sub

06/10/2012, 11h07
zealot37

Je m'incline... ça fonctionne à merveille, j'ai juste changé 2 offset.

Merci Mercatog, merci fring, vous m'avez tous les deux beaucoup aidé !!! :)

Et merci pour ce forum, il y a toujours quelqu'un pour vous apporter conseils!!!! :ccool: