lien hypertexte vba auto

[ouf746]

bonjour !

moi je voudrais crée un bouton qui permet de générer les lien automatiquement sauf que j'ai envi que la macro cherche dans plusieurs répertoire windows indique si le nom indiquer dans excel figue dans le répertoire alors lui affecter le lien sinon mettre la casse en rouge pour avertir qu'il ne la pas trouver

 

[Staple1600]

Bonsoir à tous

ouf746 (bienvenue sur le forum)
Je vois que tu as enfin trouvé le bon bouton

Avec un petit fichier exemple, on y verrait plus clair, non ?
Tu veux que ta macro cherche quoi et dans quels répertoires ?

Tu veux dire que ton fichier Excel tu as une liste de noms de fichiers qui existent sur ton disque dur ?

Bref plus de détails, et un fichier exemple simplifié nous aiderait grandement à t'aider

 

[ouf746]

ahah oui enfin .. je vais justement écrire au webmaster pour lui dire que c'est une galère pour ouvrir une discussion lol ..

voici le fichier excel ...jai une colonne gamme : dans cette colonne il y'a des numéro qui corresponde a des fichiers .gif avec même nom que la cellule de la colonne ...

j'aimerai que une fois appuyer sur le bouton 'générer les liens ' la macro va chercher dans plusiseur dossier et me met le lien hypertexte sur la cellule concernes....si la macro ne trouve pas le fichier dans les different dossier windows alors il me met la cellule en rouge pour me prévenir ...

 

[Staple1600]

Re

Essaies cette première ébauche

Sub a()
Dim i As Long
Dim strPath As String
'ici mettre le chemin du dossier contenant les gif
strPath = "C:\TEMP\"
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Dir(strPath & Cells(i, 1).Text & ".gif") <> "" Then
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=strPath & Cells(i, 1).Text & ".gif", TextToDisplay:=Cells(i, 1)
Else
Cells(i, 1).Font.Bold = True
Cells(i, 1).Interior.Color = 255
End If
Next
End Sub

 

[ouf746]

ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 1), Address:=strPath & Cells(i, 1).Text & ".gif", TextToDisplay:=Cells(i, 1)


erreur ...sa ne marche pas .

 

[Staple1600]

Bonjour à tous

0uf746
Tu as suivi cette consigne ?
'ici mettre le chemin du dossier contenant les gif
strPath = "C:\TEMP\"
Donc il faut changer C:\TEMP\ par le vrai chemin du dossier où il y a des gif

 

[ouf746]

j'ai trouver l'erreur au lieu de C:\Users\admin\Desktop\TEST\GAMME\313\ faut mettre C:\Users\admin\Desktop\TEST\GAMME\313

par contre sa ne me crée pas le lien pour un gif qui porte le même nom que la cellule A2 ... sa me met en rouge donc qu'il a pas trouver le fichier

 

[Staple1600]

Re

Et comme ca?
(test OK sur mon PC)

Sub b()
Dim i As Long
Dim strPath As String
Dim F As Worksheet: Set F = ActiveSheet
'ici mettre le chemin du dossier contenant les gif
strPath = "C:\TEMP\" ' chez moi je garde le \ final
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Dir(strPath & Cells(i, 1).Text & ".gif") <> "" Then
F.Hyperlinks.Add Anchor:=F.Cells(i, 1), Address:=F.Cells(i, 1).Value, TextToDisplay:=F.Cells(i, 1).Value
Else
F.Cells(i, 1).Font.Bold = True
F.Cells(i, 1).Interior.Color = 255
End If
Next
End Sub

 

[ouf746]

bonjour,

parfait sa me surligne bien la réf parcontre le lien hypertexte n'est pas bon sa me balance sur le bureau et non sur adresse voulu : J:\PROG. ISO MODIF\01-GAMME\313\
Autre chose la casse reste en rouge meme si la macro retrouve le fichier dans mon dossier.

et dernier point je voudrais mettre plusieur chemain du genre : J:\PROG. ISO MODIF\01-GAMME\313\
J:\PROG. ISO MODIF\01-GAMME\314\
J:\PROG. ISO MODIF\01-GAMME\315\

De facon a que le programme cherche dans plusieur fichier et me met le lien coorespondant si il ne trouve pas dans plusieur lien alors il me met la case enj rouge.

merci

 

[ouf746]

Bonjour, je vous relance concernant se sujet merci

 

[ouf746]

Sub b()
Dim i As Long
Dim strPath As String
Dim F As Worksheet: Set F = Sheets("Base de données")
'ici mettre le chemin du dossier contenant les gif

strPath = " J:\PROG. ISO MODIF\01-GAMME\313\"


For i = 2 To Cells(Rows.Count, 6).End(xlUp).Row
If Dir(strPath & Cells(i, 6).Text & ".gif") <> "" Then
F.Hyperlinks.Add Anchor:=F.Cells(i, 6), Address:=strPath & F.Cells(i, 6) & ".gif", TextToDisplay:=F.Cells(i, 6).Value



F.Cells(i, 6).Font.Bold = True
F.Cells(i, 6).Interior.Color = RGB(174, 240, 194)



Else
F.Cells(i, 6).Font.Bold = False
F.Cells(i, 6).Interior.Color = 255
End If

Next

End Sub






se code marche parcontre je narrive pas a ajouter plusieur dossier la fonction if then else end if ne fonctionne pas .