Recherche auto de lien hypertexte

Bonjour à tous !

J'ai un petit problème je voudrais crée un bouton qui permet de générer les liens automatiquements :

Dans la colonne E se trouve plusieur nom de fichier ".gif " , et-t-il possible de crée une macro qui cherche dans plusieur repertoire windows si le nom qui se trouve dans la celulle E2 est presente dans les repertoire windows indiquer, si le fichier et present lui affecter le lien sinon mettre la cellule en rouge pour indiquer que le fichier n'est pas present .

Exemple : en E2 se trouve le nom : o1252 , donc la macro cherche dans les repertoire

J:\PROG. ISO MODIF\01-GAMME\314\

J:\PROG. ISO MODIF\01-GAMME\315\

J:\PROG. ISO MODIF\01-GAMME\316\

(le fichier et present dans le repertoire 316) donc lui affecte un lien hypertexte : J:\PROG. ISO MODIF\01-GAMME\316\o1252.gif

si il ne trouve pas mettre la cellule en rouge .

Merci a vous

Bonjour,

Solution déjà proposée ici : https://forum.excel-pratique.com/excel/recherche-fichier-dans-dossier-et-sous-dossier-t18587.html

Private Sub CommandButton1_Click()
Dim nomFichier As String, i As Long, cpt As Long
nomFichier = TextBox1.Text    'nom du fichier à chercher
   With Application.FileSearch
        .NewSearch
        .LookIn = "G:\S - ISO\A - Audits\"    'on regarde dans ce répertoire
       .SearchSubFolders = True    'on regarde dans les sous-dossiers également
       .Filename = nomFichier    'nom du fichier à chercher
       .MatchTextExactly = True    'on cherche dans les fichiers qui contiennent le nom du fichier cherché
       .FileType = msoFileTypeExcelWorkbooks    'on cherche que les classeur excel
       If .Execute() > 0 Then    'si un fichier est trouvé
           For i = 1 To .FoundFiles.Count    'on boucle sur tous les fichiers comportant le nom du fichier
               If .FoundFiles(i) Like "*" & nomFichier & ".xls" Then    'si le fichier correspond exactement au nom recherché
                   cpt = cpt + 1    'on incrémente un compteur
               End If
            Next i
        End If
        If cpt > 0 Then
            MsgBox "Il y a " & cpt & " " & IIf(cpt = 1, "fichier intitulé ", "fichiers intitulés ") & """" & nomFichier & """.", vbInformation
        Else
            MsgBox "Fichier Absent", vbExclamation
        End If
    End With
End Sub

Bonjour,

Application.FileSearch

ne fonctionne plus depuis Excel 2003 si je ne me trompe pas ! Regardes plutôt avec la fonction Dir() :

Sub Lien()

    Dim Plage As Range
    Dim Cel As Range
    Dim Fichier As String
    Dim Dossiers
    Dim Chemin As String

    'les dossiers où chercher
    Dossiers = Array("J:\PROG. ISO MODIF\01-GAMME\314\", "J:\PROG. ISO MODIF\01-GAMME\315\", "J:\PROG. ISO MODIF\01-GAMME\316\")

    'la palge de cellule contenant les noms (ici, sur feuille "Feuil1" en colonne E à partir de E1)
    With Worksheets("Feuil1"): Set Plage = .Range(.Cells(1, 5), .Cells(.Rows.Count, 5).End(xlUp)): End With

    'boucle sur la plage
    For Each Cel In Plage

        'boucle sur les dossiers
        For I = 0 To UBound(Dossiers)

            'cherche
            Fichier = Dir(Dossiers(I) & "*.gif")

            'si trouvé, crée le lien et sort de la boucle secondaire sinon, intérieur en rouge
            If Fichier <> "" Then

                Cel.Hyperlinks.Add Cel, Dossiers(I) & Fichier, , , Cel.Value
                Exit For

            Else

                Cel.Interior.ColorIndex = 3

            End If

        Next I

    Next Cel

End Sub

Attention, je n'ai absolument rien testé donc, à toi de déboguer mais c'est un début de piste !

Bonjour,

Sa me met bien le lien parcontre sa prend pas le nom du fichier qui se trouve dans la colonne E 1 puis E2 ainsi de suite ...

idée c'est de chercher le nom du fichier en E1 dans les different répertoire et si il trouve luis affecter le lien nom de la cellule E1.gif sinon mettre la casse en rouge .

je pense que ton code et bon il manque juste une petite correction

merci

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 .

Bonjour,

je reviens vers vous pasque je suis vraiment bloquer. Le code fonctionne parcontre je voudrais ajouter plusieur dossier :

"J:\PROG. ISO MODIF\01-GAMME\314\", "J:\PROG. ISO MODIF\01-GAMME\315\", "J:\PROG. ISO MODIF\01-GAMME\316\"

ou mettre" J:\PROG. ISO MODIF\01-GAMME\ " et avec la fonction SubFolders, aller chercher dans les sous dossiers .

Sub liens_gammes()

Dim i As Long                                            'Affectation de la variable i
Dim strPath As String                                    'Affectation de la variable Strpath
Dim F As Worksheet: Set F = Sheets("Base de données")    'Agir sur la feuille base de données

 ActiveSheet.Hyperlinks.Delete                           'Supprime tout les liens déja creer (réinitialise)
 strPath = "J:\PROG. ISO MODIF\01-GAMME\313\"
  'Chemin du dossier contenant les gammes pour la machine 313

For i = 2 To Cells(Rows.Count, 6).End(xlUp).Row          'Boucle fermer à 2 instruction

 'Rechercher dans le chemin déclarer les fichiers .gif correspondant au nom de la colonne 6 ligne + 1
 If Dir(strPath & Cells(i, 6).Text & ".gif") <> "" Then
 'Si nom trouver dans le dossier lui affacter le lien
 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                        'Liens en gras
    F.Cells(i, 6).Interior.Color = RGB(174, 240, 194)     'Cellule en vert

Else                                                      'Sinon si le nom n'est pas present alors
     F.Cells(i, 6).Font.Bold = False                      'Ne pas mettre de gras
     F.Cells(i, 6).Interior.Color = 255                   'Mettre la cellule en rouge
End If

Next
End Sub

merci pour votre aide