Création lien hypertexte selon condition cellule menu deroulante

TEMAGOULTFARID · 27 Décembre 2019

Bonjour,

a l’état actuel, en cliquant sur le bouton A, une fenêtre s'ouvre bien , je choisis le fichier a mettre en lien et vient s'inscrire dans la cellule C9 ,

ma question qui se pose:

est possible lorsque le chemin du fichier a été sélectionné et viens s’inscrire dans la cellule C9 puisse être mis en lien hypertexte afin que je puisse revenir dessus ,

et la deuxième question, en cliquant sur le boutonA que l'ouverture de la fenêtre du chemin du dossier soit celui choisi de la cellule A2,

en resumer , je clic sur le boutonA , ouverture du dossier selon choix cellule A2 , et dans ce dossier je clic sur le fichier scanner et son chemin vient se coller dans la cellule C9 en lien Hypertexte ainsi je pourrais clic sur le lien et ouvrir le fichier

par avance , merci

Dudu2 · 27 Décembre 2019

Bonjour,
La liste des répertoires en cellule A2 doit contenir le chemin complet y compris la lettre du drive (ex: D:\Documents\Test1)

VB:

Option Explicit

Sub ListeDesDocDansDossier()
    Const CelluleRépertoire = "A2"
    Const CelluleFichier = "C9"
   
    Call SelectionFichier(ActiveSheet.Range(CelluleRépertoire), ActiveSheet.Range(CelluleFichier))
End Sub

Sub SelectionFichier(CelluleRépertoire As Range, CelluleFichier As Range)
    Dim TabFichier As Variant
    Dim RépertoireCourant As String
    Dim ErrNumber As Integer
   
    'Sauvegarde du répertoire courant
    RépertoireCourant = CurDir
   
    'Changement de répertoire
    On Error Resume Next
    ChDrive Left(CelluleRépertoire.Value, 2)
    ChDir CelluleRépertoire.Value
    ErrNumber = Err.Number
    On Error GoTo 0
   
    If ErrNumber <> 0 Then
        MsgBox "Répertoire en cellule " & CelluleRépertoire.Address & " incorrect !"
        GoTo FinSub
    End If
   
    'Sélection d'un fichier dans le répertoire
    TabFichier = Application.GetOpenFilename(, , , , True)
    If VarType(TabFichier) = vbBoolean Then
        MsgBox "Aucun fichier sélectionné !"
        GoTo FinSub
    End If
   
    'Hyperlink sur le fichier sélectionné en cellule
    ActiveSheet.Hyperlinks.Add Anchor:=CelluleFichier, _
        Address:=TabFichier(1), TextToDisplay:=TabFichier(1)
       
FinSub:
    'Restore répertoire courant
    ChDrive Left(RépertoireCourant, 2)
    ChDir RépertoireCourant
End Sub

TEMAGOULTFARID · 27 Décembre 2019

Dudu2 à dit:

Bonjour,
La liste des répertoires en cellule A2 doit contenir le chemin complet y compris la lettre du drive (ex: D:\Documents\Test1)

VB:

Option Explicit

Sub ListeDesDocDansDossier()
    Const CelluleRépertoire = "A2"
    Const CelluleFichier = "C9"
  
    Call SelectionFichier(ActiveSheet.Range(CelluleRépertoire), ActiveSheet.Range(CelluleFichier))
End Sub

Sub SelectionFichier(CelluleRépertoire As Range, CelluleFichier As Range)
    Dim TabFichier As Variant
    Dim RépertoireCourant As String
    Dim ErrNumber As Integer
  
    'Sauvegarde du répertoire courant
    RépertoireCourant = CurDir
  
    'Changement de répertoire
    On Error Resume Next
    ChDrive Left(CelluleRépertoire.Value, 2)
    ChDir CelluleRépertoire.Value
    ErrNumber = Err.Number
    On Error GoTo 0
  
    If ErrNumber <> 0 Then
        MsgBox "Répertoire en cellule " & CelluleRépertoire.Address & " incorrect !"
        GoTo FinSub
    End If
  
    'Sélection d'un fichier dans le répertoire
    TabFichier = Application.GetOpenFilename(, , , , True)
    If VarType(TabFichier) = vbBoolean Then
        MsgBox "Aucun fichier sélectionné !"
        GoTo FinSub
    End If
  
    'Hyperlink sur le fichier sélectionné en cellule
    ActiveSheet.Hyperlinks.Add Anchor:=CelluleFichier, _
        Address:=TabFichier(1), TextToDisplay:=TabFichier(1)
      
FinSub:
    'Restore répertoire courant
    ChDrive Left(RépertoireCourant, 2)
    ChDir RépertoireCourant
End Sub

Tout simplement magnifique, çà fonctionne nickel.Merci infiniment

TEMAGOULTFARID · 28 Décembre 2019

Bonjour Dudu, je reviens vers toi concernant ma demande dont ta solution fonctionne très bien, je vais abuser , mais est ce possible que le lien hypertexte qui s'affiche en C9 en texte que l'on puisse mettre une image en conservant le lien hypertexte.En résume, lorsque l'intervenant scan le fichier qui va être placé dans le dossier concerné, ira le chercher via ta macro et que dans al cellule C9 soit afficher une image style PDF avec le lien.
j'ai beau chercher dan le web, j'ai trouvé certain truc main ne correspond pas a ce que je souhaite.Par avance , merci

Dudu2 · 28 Décembre 2019

Bonjour Tema,
J'ai supposé que tu ne voulais qu'une seule image quelque soit le type de fichier sélectionné. Il serait possible de programmer une image par type de fichier pour les types classiques (ex: .pdf, .jpg, .doc, .xls, autre) si besoin.

La procédure est la suivante:
- Copier l'image de ton choix (prise sur Internet ou ailleurs) dans la Feuil2
- Utiliser l'utilitaire fourni (VBA Objets Shapes identifier, supprimer, renommer.xlsm) pour la renommer en "ImagePourLeLien" ou tout autre nom à condition d'adapter la constante (Const NomShapeImage = "ImagePourLeLien") en conséquence.
- Utiliser le code suivant (j'ai posté ton fichier d'origine avec ce code et une image choisie sur Internet)

VB:

Option Explicit

Sub ListeDesDocDansDossier()
    Const CelluleRépertoire = "A2"
    Const CelluleFichier = "C9"
    Const NomShapeImage = "ImagePourLeLien"
  
    Call SelectionFichier(ActiveSheet.Range(CelluleRépertoire), ActiveSheet.Range(CelluleFichier), Worksheets("Feuil2").Shapes(NomShapeImage))
End Sub

Sub SelectionFichier(CelluleRépertoire As Range, CelluleFichier As Range, Image As Shape)
    Dim TabFichier As Variant
    Dim RépertoireCourant As String
    Dim NomShapeImage As String
    Dim ErrNumber As Integer
      
    'Nom de l'image pour le lien
    NomShapeImage = Image.Name

    'Sauvegarde du répertoire courant
    RépertoireCourant = CurDir
  
    'Changement de répertoire
    On Error Resume Next
    ChDrive Left(CelluleRépertoire.Value, 2)
    ChDir CelluleRépertoire.Value
    ErrNumber = Err.Number
    On Error GoTo 0
  
    If ErrNumber <> 0 Then
        MsgBox "Répertoire en cellule " & CelluleRépertoire.Address & " incorrect !"
        GoTo FinSub
    End If
  
    'Sélection d'un fichier dans le répertoire
    TabFichier = Application.GetOpenFilename(, , , , True)
    If VarType(TabFichier) = vbBoolean Then
        MsgBox "Aucun fichier sélectionné !"
        GoTo FinSub
    End If
  
    'Supprime l'image actuelle
    On Error Resume Next
    ActiveSheet.Shapes(NomShapeImage).Delete
    On Error GoTo 0
  
    'Copie l'image fournie en argument dans la cellule fichier fournie en argument
    Image.Copy
    CelluleFichier.Select
    ActiveSheet.Paste
  
    'Insert le lien hypertexte
    ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes(NomShapeImage), Address:=TabFichier(1)
    If CelluleFichier.Column > 1 Then CelluleFichier.Offset(0, -1).Select
    GoTo FinSub
      
FinSub:
    'Restore répertoire courant
    ChDrive Left(RépertoireCourant, 2)
    ChDir RépertoireCourant
End Sub

TEMAGOULTFARID · 28 Décembre 2019

tout simplement magistrale,en plus de petite application pour renommer les fichier image, c'est sublime.Je te remercie infiniment tu m'as rendu un grand service et ça fonctionne nickel.Je l'ai adapter au fichier concerné.Peut une dernière demande (j'ai dit peut être ), dans le fichier pour que le programme puisse s'appliquer il faut une condition comme dans cette exemple de la cellule A2. Est-ce possible de mettre plusieurs conditions, c'est a dire la cellule A2 +C4+D8 avec un MsgBox s'il manque ces 3 conditions.Je travail sur un fichier de plan de maintenance et j'aurai souhaiter mettre plusieurs conditions.Par avance, un grand merci en te souhaitant une bonne journée

Dudu2 · 28 Décembre 2019

Je ne comprends pas cette histoire de condition.
De quel exemple de la cellule A2 parles-tu ?
Tu n'aurais pas oublié de joindre un fichier ?
Explique plus clairement les conditions en question.
(Envoyé de mon smartphone)

TEMAGOULTFARID · 28 Décembre 2019

Oups , désolé si je me suis mal exprimer . Je voulais dire dans le fichier "Lien Hypertexte V2" , dans la macro ci dessous,les ligne en rouge permet de ne pas appliquer l'action si la cellule A2 ne remplie l'action : Const CelluleRépertoire = "A2"et donc la question :est ce qu'il est possible de mettre plusieurs conditions en plus de celle de la cellule de A2 "exepemle Cellules A2+C8+D9 pour pouvoir ouvrir le dossier du fichier choisi qui va aller dans la cellule C9.
Jespere que j'ai utilisé les bons mots.
et encore merci

Option Explicit

Sub ListeDesDocDansDossier()
Const CelluleRépertoire = "A2"
Const CelluleFichier = "C9"
Const NomShapeImage = "ImagePourLeLien"

Call SelectionFichier(ActiveSheet.Range(CelluleRépertoire), ActiveSheet.Range(CelluleFichier), Worksheets("Feuil2").Shapes(NomShapeImage))
End Sub

Sub SelectionFichier(CelluleRépertoire As Range, CelluleFichier As Range, Image As Shape)
Dim TabFichier As Variant
Dim RépertoireCourant As String
Dim NomShapeImage As String
Dim ErrNumber As Integer

'Nom de l'image pour le lien
NomShapeImage = Image.Name

'Sauvegarde du répertoire courant
RépertoireCourant = CurDir

'Changement de répertoire
On Error Resume Next
ChDrive Left(CelluleRépertoire.Value, 2)
ChDir CelluleRépertoire.Value
ErrNumber = Err.Number
On Error GoTo 0

If ErrNumber <> 0 Then
MsgBox "Répertoire en cellule " & CelluleRépertoire.Address & " incorrect !"
GoTo FinSub
End If

'Sélection d'un fichier dans le répertoire
TabFichier = Application.GetOpenFilename(, , , , True)
If VarType(TabFichier) = vbBoolean Then
MsgBox "Aucun fichier sélectionné !"
GoTo FinSub
End If

'Supprime l'image actuelle
On Error Resume Next
ActiveSheet.Shapes(NomShapeImage).Delete
On Error GoTo 0

'Copie l'image fournie en argument dans la cellule fichier fournie en argument
Image.Copy
CelluleFichier.Select
ActiveSheet.Paste

'Insert le lien hypertexte
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes(NomShapeImage), Address:=TabFichier(1)
If CelluleFichier.Column > 1 Then CelluleFichier.Offset(0, -1).Select
GoTo FinSub

FinSub:
'Restore répertoire courant
ChDrive Left(RépertoireCourant, 2)
ChDir RépertoireCourant
End Sub

Dudu2 · 28 Décembre 2019

La cellule A2 doit contenir un répertoire. Si ce répertoire n'est pas valide, alors on passe dans la séquence de détection de l'erreur.

Que contiennent les 2 autres cellules C8 et D9 ? Et quelles sont les conditions à appliquer à leurs contenus respectifs pour que la Macro continue de s'exécuter ?
Exemple:
- La cellule C8 contient le nom d'un fromage. Condition: si le nom du fromage n'est pas "camembert" il faut arrêter la Macro.
- La cellule D9 contient une photo de chanteuse. Condition: si la chanteuse est blonde il faut arrêter la Macro.

Comment veux-tu que je devine le contenu de ces 2 cellules supplémentaires et les conditions que tu veux leur appliquer ?
Est-ce qu'on part sur le camembert et la blonde ? Ou bien tu as d'autres informations à donner ?

TEMAGOULTFARID · 28 Décembre 2019

tres bien, La cellule D8 contient des heures de travail et la cellule C9 contient une liste déroulante de nom et prénoms, pour ce dernier il faut obligatoirement un nom .
merci a toi et dommage pour la blonde

Dudu2 · 28 Décembre 2019

Ok, tu ne me donnes encore que la moitié de l'info !
?? -> La 1ère cellule contient des heures de travail. Ok. Et la condition c'est quoi ? Il faut qu'elle soit non vide ? Contienne un nombre > 0 ? S'il ny a pas d'heure elle est vide ou bien contient 0 ? Quel est le format de la cellule ?
OK -> La 2ème cellule contient un Nom & Prénom et la condition est qu'elle soit non vide.

Dudu2 · 28 Décembre 2019

VB:

Sub ListeDesDocDansDossier()
    Const CelluleRépertoire = "A2"
    Const CelluleFichier = "C9"
    Const CelluleHeuresDeTravail = "C1"
    Const CelluleNomPrénom = "C2"
    Const NomShapeImage = "ImagePourLeLien"
    
    If ActiveSheet.Range(CelluleHeuresDeTravail).Value = 0 Then
        MsgBox "La cellule " & CelluleHeuresDeTravail & " des heures de travail ne contient pas d'heures !"
        Exit Sub
    End If
    
    If IsEmpty(ActiveSheet.Range(CelluleNomPrénom)) Then
        MsgBox "La cellule " & CelluleNomPrénom & " du Nom et Prénom est vide !"
        Exit Sub
    End If
    
    Call SelectionFichier(ActiveSheet.Range(CelluleRépertoire), ActiveSheet.Range(CelluleFichier), Worksheets("Feuil2").Shapes(NomShapeImage))
End Sub

TEMAGOULTFARID · 29 Décembre 2019

Dudu2 à dit:
Ok, tu ne me donnes encore que la moitié de l'info !
?? -> La 1ère cellule contient des heures de travail. Ok. Et la condition c'est quoi ? Il faut qu'elle soit non vide ? Contienne un nombre > 0 ? S'il ny a pas d'heure elle est vide ou bien contient 0 ? Quel est le format de la cellule ?
OK -> La 2ème cellule contient un Nom & Prénom et la condition est qu'elle soit non vide.

Bonjour a toi ,
encore désolé si je ne suis mal exprimé, je n'ai pas encore atteint le niveau de langage nécessaire pour m'exprimer a la hauteur des VBAman/girl.en réponse a tes question lié a ma demande.
la première cellule si vide (heure format 37:30:55) alors affichage MsgBox "Veuillez mettre le temps passé"
la deuxième cellule si vide (Pas de texte) alors affichage Msg "Veuillez mettre un Nom Intervenant"

voila, si il manque une ces conditions + celle deja ecrit (cellule A2) alors on ne pourrat pas crée "ImagePourLeLien"
j'espère que cette fois ci c'est bon et encore merci

TEMAGOULTFARID · 29 Décembre 2019

TEMAGOULTFARID à dit:
Bonjour a toi ,
encore désolé si je ne suis mal exprimé, je n'ai pas encore atteint le niveau de langage nécessaire pour m'exprimer a la hauteur des VBAman/girl.en réponse a tes question lié a ma demande.
la première cellule si vide (heure format 37:30:55) alors affichage MsgBox "Veuillez mettre le temps passé"
la deuxième cellule si vide (Pas de texte) alors affichage Msg "Veuillez mettre un Nom Intervenant"

voila, si il manque une ces conditions + celle deja ecrit (cellule A2) alors on ne pourrat pas crée "ImagePourLeLien"
j'espère que cette fois ci c'est bon et encore merci

Oups , je n'avais pas vu ton deuxième post, c'est bien cela que je voulais ey cela fonctionne.
merci infiniment pour ton implication , cela m'a fait avancé sur mon projet
en te souhaitant une bonne journée

Dudu2 · 29 Décembre 2019

Bonjour,
Si ça te va, c'est parfait.
Je ne crois pas qu'il y ait un langage particulier pour les VBA men/girls. Simplement ils n'ont pour la plupart pas le don de voyance et quand on leur soumet un sujet il faut leur donner toutes les informations.
Si je te dis: <Va chez Marcel et donne lui l'argent si c'est OK> est-ce que ça te suffira ?
Il te faudra savoir 1) où habite Marcel et 2) qu'est-ce qui fera que ce sera OK ou pas. C'est aussi simple que ça.
Bonne journée
D.

Création lien hypertexte selon condition cellule menu deroulante

TEMAGOULTFARID

XLDnaute Occasionnel

Pièces jointes

Dudu2

XLDnaute Barbatruc

TEMAGOULTFARID

XLDnaute Occasionnel

TEMAGOULTFARID

XLDnaute Occasionnel

Dudu2

XLDnaute Barbatruc

Pièces jointes

TEMAGOULTFARID

XLDnaute Occasionnel

Dudu2

XLDnaute Barbatruc

TEMAGOULTFARID

XLDnaute Occasionnel

Pièces jointes

Dudu2

XLDnaute Barbatruc

TEMAGOULTFARID

XLDnaute Occasionnel

Dudu2

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

TEMAGOULTFARID

XLDnaute Occasionnel

TEMAGOULTFARID

XLDnaute Occasionnel

Dudu2

XLDnaute Barbatruc

Discussions similaires