Format de cellule personnalisé en hyperlien dans la même cellule

[Cydor007]

Bonjour à tous,

J'ai besoin de vos lumières.

Est-ce que c'est possible de personnaliser un format de cellule pour qu'il soit toujours en hyperlien ?

Je m'explique: J'aimerais entré un numéro de pièce dans une cellule A1, ex S-1001-2022, et que quand j'entre le # la cellule se transforme en hyperlien. La cible est toujours la même. Cela doit ouvrir un pdf dans un répertoire où il y a des milliers de pdf enregistrés.

Le but est de m'évité d'entrer la valeur dans une autre cellule, ex. B1, et faire une formule du genre =LIEN_HYPERTEXTE(B1&"\"&C1&".PDF";A1).

Quelqu'un a une idée... je ne suis pas fermer de travailler en VBA.

Merci

Cydor007

 

[job75]

Bonjour Cydor007,

Si l'on ne veut pas utiliser la fonction LIEN_HYPERTEXTE il faut bien sûr du VBA.

Et faire un certain nombre de contrôles avant de créer le lien :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, dossier$, ad$
Set c = [A1] 'cellule à adapter
dossier = ThisWorkbook.Path & "\Fichiers PDF" 'à adapter
If Dir(dossier, vbDirectory) = "" Then MsgBox "Dossier '" & dossier & "' introuvable !", 48: Exit Sub
If Intersect(Target, c) Is Nothing Then Exit Sub
c.Hyperlinks.Delete 'RAZ
c.Font.ColorIndex = xlAutomatic
c.Font.Underline = xlUnderlineStyleNone
If c = "" Then Exit Sub
ad = dossier & "\" & c & ".pdf"
If Dir(ad) = "" Then MsgBox "Fichier '" & c & ".pdf' introuvable !", 48: Exit Sub
c.Hyperlinks.Add c, ad 'création du lien hypertexte
End Sub

La macro est à placer dans le code de la feuille (clic droit sur l'onglet et Visualiser le code).

A+

 

[job75]

Re,

Si l'on veut créer des liens sur toute la colonne A c'est un peu plus compliqué :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, dossier$, ad$
Set r = [A:A] 'colonne A à adapter
dossier = ThisWorkbook.Path & "\Fichiers PDF" 'à adapter
If Dir(dossier, vbDirectory) = "" Then
  MsgBox "Dossier '" & dossier & "' introuvable !", 48
  With Application
    .EnableEvents = False: .Undo: .EnableEvents = True
  End With
  Exit Sub
End If
Set r = Intersect(Target, r, Me.UsedRange)
If r Is Nothing Then Exit Sub
r.Hyperlinks.Delete 'RAZ
r.Font.ColorIndex = xlAutomatic
r.Font.Underline = xlUnderlineStyleNone
For Each r In r 'si entrées/effacements multiples (copier-coller)
  If r <> "" Then
    ad = dossier & "\" & r & ".pdf"
    If Dir(ad) = "" Then
      MsgBox "Fichier '" & r & ".pdf' introuvable !", 48
    Else
      r.Hyperlinks.Add r, ad 'création du lien hypertexte
    End If
  End If
Next
End Sub

A+

 

[Cydor007]

Ok job 75,

Je valide le tout et te revient pour te confirmer si cela fonctionne bien. Merci

Cydor007

 

[Cydor007]

Job75,

Est-ce qu'on peut appliquer cette méthode sur plus d'une colonne dans la même feuille ?

Merci

 

[job75]

Re,

J'ai bien précisé "à adapter", sur les colonnes A:H par exemple :

Set r = [A:H] 'colonnes à adapter

et sur les colonnes A C E G :

Set r = [A:A,C:C,E:E,G:G] 'colonnes à adapter

A+

 

[Cydor007]

Bonjour Job75,

Quand j'entre un numéro dans la cellule AI ex. S-5023-5103 et rien ne ce passe.

Voici mon code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range, dossier$, ad$
Set c = [K3] 'cellule à adapter
dossier = "Q:\Ingenierie\D.I.R\" '& "\Fichiers PDF" 'à adapter "Q:\Ingenierie\D.I.R\S-5023-5103.pdf"
If Dir(dossier, vbDirectory) = "" Then MsgBox "Dossier '" & dossier & "' introuvable !", 48: Exit Sub
If Intersect(Target, c) Is Nothing Then Exit Sub
c.Hyperlinks.Delete 'RAZ
c.Font.ColorIndex = xlAutomatic
c.Font.Underline = xlUnderlineStyleNone
If c = "" Then Exit Sub
ad = dossier & "\" & c & ".pdf"
If Dir(ad) = "" Then MsgBox "Fichier '" & c & ".pdf' introuvable !", 48: Exit Sub
c.Hyperlinks.Add c, ad 'création du lien hypertexte
End Sub

Qu'est ce que je dois faire pour que cela fonctionne?

Merci

Cydor007

 

[job75]

Re,

Vous plaisantez ou quoi ? Vous parlez de cellule AI (???) et vous écrivez Set c = [K3]

Par ailleurs il ne faut pas de \ à la fin du texte définissant la variable dossier.

A+

 

[Cydor007]

ob75,

Je ne plaisantais pas... Mon intervention au début était qu'un exemple... Que ce soit A1, B25 OU K3.. Ce sont tous des cellules.

Dans mon classeur se sont les colonnes K, P, V, où il y a ce type de cellule. Mais à partir de la ligne 3.

Donc si j'ai bien compris, je dois écrire: Set r = [K3:K10000,P310000,V3:V10000]

Est-ce que vous confirmer?

Merci

Cydor007

 

[Cydor007]

Bonjour,

Voici mon code, mais quand j'édite la cellule K3, il ne se passe rien.

Dim r As Range, dossier$, ad$
Set r = [K3:K10000,P310000,V3:V10000] 'colonne A à adapter
dossier = "Q:\Ingenierie\D.I.R" '& "\Fichiers PDF" 'à adapter "Q:\Ingenierie\D.I.R\S-5023-5103.pdf"
If Dir(dossier, vbDirectory) = "" Then
MsgBox "Dossier '" & dossier & "' introuvable !", 48
With Application
.EnableEvents = False: .Undo: .EnableEvents = True
End With
Exit Sub
End If
Set r = Intersect(Target, r, Me.UsedRange)
If r Is Nothing Then Exit Sub
r.Hyperlinks.Delete 'RAZ
r.Font.ColorIndex = xlAutomatic
r.Font.Underline = xlUnderlineStyleNone
For Each r In r 'si entrées/effacements multiples (copier-coller)
If r <> "" Then
ad = dossier & "\" & r & ".pdf"
If Dir(ad) = "" Then
MsgBox "Fichier '" & r & ".pdf' introuvable !", 48
Else
r.Hyperlinks.Add r, ad 'création du lien hypertexte
End If
End If
Next

Qu'est-ce que je dois faire d'autre?

Pouvez-vous m'aider?

Merci

Cydor007

 

[job75]

Re,

La macro (avec Private Sub Worksheet_Change...) doit être, comme je l'ai dit au post #2, dans le code de la feuille.

La cellule que vous validez (K3) ne doit pas être vide.

Et bien sûr il faut avoir activé les macros à l'ouverture du fichier si c'est demandé.

Je ne peux rien vous dire de plus, chez moi il n'y a aucun problème.