Rajouter un lien hypertexte. (Résolu ou presque)

[T77XDD]

Bonjour,
je suis en mesure de rajouter un lien hypertexte à la fin de chaque ligne de la feuille:

Option Explicit
Sub Hyperlien()

Dim Bat As String
Dim App As String
Dim Loc As String
Dim Ents As String
Dim DPnum As String
Dim Obj As String
Dim NomFichierPDF As String
Dim Filename As String
Dim i As Integer

With Sheets("Récap DP")
For i = 2 To .Range("A65535").End(xlUp).Row
    Bat = .Range("H" & i)
    App = .Range("G" & i)
    Loc = .Range("I" & i)
    Ents = .Range("O" & i)
    DPnum = .Range("X" & i)
    Obj = .Range("R" & i)
    

If Left(.Range("X" & i), 1) = "F" Then
    'enr Fax
    NomFichierPDF = "Fax" & " " & DPnum & " " & Obj & " " & Ents
    Filename = "C:\DP\Fax\" & Ents & "\" & NomFichierPDF & ".pdf"
    
Else
    'enr DP Parties communes
    If App = "0" Then
    NomFichierPDF = "DP" & " " & DPnum & " " & Loc & " " & Ents
    Filename = "C:\DP\PartiesCommunes\" & Ents & "\" & NomFichierPDF & ".pdf"
    
Else
    'enr DP Locataires
    NomFichierPDF = "DP" & " " & DPnum & " " & Loc & " " & Ents
    Filename = "C:\DP\" & Bat & "\" & App & "\" & NomFichierPDF & ".pdf"
    End If
End If
    
ActiveCell.Hyperlinks.Add _
    Anchor:=Range("Z" & i), _
    Address:=Filename, _
    TextToDisplay:=NomFichierPDF
   Next i
End With

Je cherche à rajouter

ActiveCell.Hyperlinks.Add _
    Anchor = .Range("Z"), _
    Address:=Filename, _
    TextToDisplay:=NomFichierPDF

Dans le code suivant pour générer cet hyperlien à la fin de la ligne en cliquant sur le bouton "ImpEnr"

Option Explicit
Sub ImpEnrFaxDp()

If Left(ActiveCell, 1) = "F" Then

Selection.Copy
   Sheets("FAX").Select
   Range("I2").Select
   ActiveSheet.Paste
   Range("I3").Select

'With ActiveSheet
    '.PageSetup.BlackAndWhite = True
    '.PrintOut
'End With

Dim DPnum$, Bat$, App$, Loc$, Ents$, Obj$, Filename$, NomFichierPDF As String, derlig$, Tableau() As String
ActiveCell.CurrentRegion.Select
ReDim Tableau(1 To ActiveCell.CurrentRegion.Count)

DPnum = Sheets("FAX").Range("I1")
Ents = Sheets("FAX").Range("F14")
Obj = Sheets("FAX").Range("C25")

NomFichierPDF = "Fax" & " " & DPnum & " " & Obj & " " & Ents
Sheets("FAX").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="C:\DP\Fax\" & Ents & "\" & NomFichierPDF & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

Else

    Selection.Copy
    Sheets("DP").Select
    Range("I2").Select
    ActiveSheet.Paste
    Range("I3").Select

    'With ActiveSheet
        '.PageSetup.BlackAndWhite = True
        '.PrintOut
    'End With



    DPnum = Sheets("DP").Range("I1")
    Bat = Sheets("DP").Range("C5")
    App = Sheets("DP").Range("C7")
    Loc = Sheets("DP").Range("C8")
    Ents = Sheets("DP").Range("E8")



    'enr DP PC
    If App = "0" Then
        NomFichierPDF = "DP" & " " & DPnum & " " & Loc & " " & Ents
        Sheets("DP").ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:="C:\DP\PartiesCommunes\" & Ents & "\" & NomFichierPDF & ".pdf", _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=False, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    
    Else

        'enr PC Locataires
            NomFichierPDF = "DP" & " " & DPnum & " " & Loc & " " & Ents
            Sheets("DP").ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:="C:\DP\" & Bat & "\" & App & "\" & NomFichierPDF & ".pdf", _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=False, _
            IgnorePrintAreas:=False, _
         OpenAfterPublish:=False

     End If

End If

ActiveCell.Hyperlinks.Add _
    Anchor = .Range("Z"), _
    Address:=Filename, _
    TextToDisplay:=NomFichierPDF

    Sheets("Récap DP").Select
    derlig = [C65000].End(xlUp).Row + 1
    Range(Cells(derlig, 1), Cells(derlig, 1)).Select

End Sub

et pani rien à faire
Je tourne en rond depuis un moment les 2 séparément fonctionnent puis c'est tout, rien à faire (pour moi s'entend)
J'ai cherché dans les autres discussions, des bouquins y'a pas
Merci de tout ce que vous pourrez m'amener.

 

[Theze]

Re : Rajouter un lien hypertexte.

Bonjour,

Je viens de survoler ton code et la ligne :

ActiveCell.Hyperlinks.Add _
    Anchor = .Range("Z"), _
    Address:=Filename, _
    TextToDisplay:=NomFichierPD

pose problème car tu ne défini pas de cellule précise, "Range("Z")" devrait plutôt être l'adresse précise d'une cellule du style "Range("Z1")"

Hervé.

 

[T77XDD]

Re : Rajouter un lien hypertexte.

Bonsoir,
merci pour cette réponse rapide, mais comme tu le dis c'est mon problème, comment dire rajoutes dans la dernière colonne du tableau sur la ligne que tu traites cet hyperlien!

dans le 1er code (que je n'ai pas inventé, loin de là) la variable i fait que toutes les lignes depuis le début du tableau sont traitées même si le traitement va très vite cela ne me semble pas logique.

En supprimant la boucle "For ... Next" ça ne fonctionne pas et dercolumn non plus....
Voilà je crois que c'est la syntaxe de Range qu'il faut trouver.

Merci encore

 

[T77XDD]

Re : Rajouter un lien hypertexte.

Bonsoir,
j'ai trouvé la solution plustôt une béquille puisque à chaque création de ligne la totalité des liens hypertexte sont "recalculés" sait pas ce qu'il faut dire.
En tout cas le boulot se fait!!!
Mal, mais il se fait.
Donc j'ai modifié le module "Hyperlien" en enlevant "Option Explicit" et modifié "Sub Hyperlien()" en "Public Sub Hyperlien()" et en suite rajouter "Hyperlien" dans "ImpEnrFaxDP" juse avant de sélectionner la 1ere case de la dernière ligne.
Si vouz avez une solution plus "élégante" (Mon prof de maths aimait qu'il y avait toujours une solution plus élégante) merci de la partager.