[XL-2007] lien hypertexte automatique

[tompom3108]

Bonjour à tous,
Je cherche un moyen d'automatiser un lien hypertexte sur des fichiers enregistrés.

Je m'explique : J'ai un devis rédigé sur une feuille excel et enregistré dans un répertoire (dans l'exemple F:\Atest\) .

Dans le code utilisé, en plus d'enregistrer une copie du devis, j'archive sur une feuille d'un autre classeur (WB("Devisprovisoire").DP!) des données de ce devis. (les données sont N°Devis, Date du Devis, Nom Client, Indice, Montants).

J'aimerai que le N°Devis soit en lien hypertexte avec la feuille Devis enregistrée dans le repertoire.

J'ai essayé d'intégrer un code de lien hypertexte dans le mien ça ne marche pas

Code :

1
2
3
4
5
6
7
8
9
Sub lienhypertexte()
'
' lienhypertexte Macro
    Range("A10").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
        "SDV-2011-1114-1%20A.C.B.Activité%20Construction%20Batiment.xlsx", _
        TextToDisplay:="SDV-2011-1114-1"
 
End Sub

Je ne sais pas bien comment déclarer les variables pour que cela marche automatiquement.

Voici le code de sauvegarde et d'archivage dans lequel je voudrai inclure ce lien hypertexte.

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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Sub A_Devis()
 
'Do
    'Nb_Ex = InputBox("Nombre d'exemplaires (>1) :", "Impression", 2)
    'Loop Until Nb_Ex >= 2
'If Not (IsNumeric(Nb_Ex)) Then Exit Sub
 
Repertoire = Sheets("Menu").Range("C9").Value
    Num_Fact = Range("F19").Value
    Nom_client = Range("J13").Value
 
ActiveSheet.Copy
 
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
Range("A1").Select
 
'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
'Range("J10").Value = "Duplicata Devis"
 
'ActiveWindow.SelectedSheets.PrintOut Copies:=Nb_Ex - 1, Collate:=True
'Range("K10").Value = "Devis"
 
'Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Repertoire & Num_Fact & " " & Nom_client & ".xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = True
 
Call A_infosdevis
 
ThisWorkbook.Activate
 
    Sheets("Menu").Activate
    Range("C10").Value = Range("C10").Value + 1
 
 
 
MsgBox "Le devis n° " & Num_Fact & vbCrLf & " pour le client " & Nom_client & vbCrLf & " a bien été archivé.", vbInformation + vbOKOnly, "Archivage devis"
 
 
End Sub
 
Sub A_infosdevis()
 
Num_Fact = Range("F19").Value
    Date_Fact = Range("L5").Value
        Nom_client = Range("J13").Value
            Montant_DevisHT = Range("M57").Value
                Montant_DevisTTC = Range("M59").Value
                Indice_Devis = Range("G19").Value
 
Application.Workbooks.Open "f:\Atest\Devisprovisoire.xlsx"
 
Sheets("DP").Activate
    Range("A1").Select
If Range("A2").Value <> "" Then ActiveCell.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
 
        ActiveCell.Value = Num_Fact
      ActiveCell.Offset(0, 1).Value = Date_Fact
      ActiveCell.Offset(0, 2).Value = Nom_client
      ActiveCell.Offset(0, 3).Value = Indice_Devis
      ActiveCell.Offset(0, 4).Value = Montant_DevisHT
      ActiveCell.Offset(0, 5).Value = Montant_DevisTTC
 
 
ActiveWorkbook.Saved = False
 
ActiveWorkbook.Close
 
 
End Sub

Bon pour finir je mets en pièces jointes les classeurs concernés...
Modèle devis vba.xlsx Devisprovisoire.xlsx

Si quelqu'un à le courage de me renseigner merci d'avance.