Macro recherche de fichiers en fonction de chemin,texte,extension

E

Emmanuel31

XLDnaute Occasionnel
Bonjour à toutes et à tous !:cool:

J'ai trouvé sur internet une macro qui permet de rentrer 3 paramètres (chemin, texte, extension) et ainsi en l'exécutant de créer un lien hypertexte du ou des fichiers avec l'extension demandée et contenant le texte demandé dans le chemin demandé.:)

En gros et pour faire simple si vous mettez :
- chemin : C:\test\
- texte : test1
- extension : .xls
la macro vous créra le ou les liens vers tous les fichiers excel dans C:\test contenant en titre le nom de test1

Là ou je sollicite votre aide, c'est concernant la modification de cette macro ...:confused:

Je souhaite faire fonctionner cette macro en boucle à partir de cellules contenant le texte à chercher.

c-a-d en
- A1 : le texte est "test1"
- A2 : le texte est "test2"
- A3 : le texte est "test3"

Le but étant d'avoir en B1 B2 et B3 les liens fichiers correspondants.

Y'a-t-il un expert dans le coin qui pourrait m'aider svp ?:confused:

Merci !:D
 

Pièces jointes

  • RechercheFichier.xls
    30 KB · Affichages: 75
  • RechercheFichier.xls
    30 KB · Affichages: 74
  • RechercheFichier.xls
    30 KB · Affichages: 77
  • RechercheFichier.JPG
    RechercheFichier.JPG
    9 KB · Affichages: 83
Trier par date Trier par votes
E

Emmanuel31

XLDnaute Occasionnel
Re : Macro recherche de fichiers en fonction de chemin,texte,extension

Salut Softmama !

Aller, encore un dernier effort et j'y suis !

J'ai donc modifier en ceci :
Code: 
  If c <> "" And Left(c, 1) = "1" And c.Hyperlinks.Count = 0 Then

En effet, j'ai rajouté le fait que la sélection commence par 1 car ce que je recherche commence forcément par 1 , et cela m'évite que le script ne passe sur les cellules avec le titre (via des cellules fusionnées).

J'en suis maintenant à un cas de figure spécial !

Le cas d'un fichier qui est dans "C:\test\test a valider\" (c'est le seul sous-répertoire).
Avec le script, le lien est créé dans le sous répertoire, pas de problème.
Mais le script ne repasse plus vu que lien existe déjà ...

OR tout ce qui est dans "C:\test\test a valider\" est amené à être validé et à passer dans "C:\test\" .

Une idée du code à rajouter dans
Code: 
  If c <> "" And Left(c, 1) = "1" And c.Hyperlinks.Count = 0 Then
pour rajouter un test sur le lien hypertexte afin de voir s'il contient "test a valider" , et s'il le contient -> exécution ?????
 
Vote positif 0 Vote négatif
E

Emmanuel31

XLDnaute Occasionnel
Re : Macro recherche de fichiers en fonction de chemin,texte,extension

Hihihi ...

La macro sur laquelle tu m'as aidé hier fonctionne très bien (voir page d'avant de ce même post).

J'aimerais juste rajouter un test à
Code: 
If c <> "" And Left(c, 1) = "1" And c.Hyperlinks.Count = 0 Then

Le test serait (en français ;-) et en plus des conditions ci-dessus) :

-> si l'hyperlien de c contient "\test a valider\"
cad au final :

If c <> "" And Left(c, 1) = "1" And c.Hyperlinks.Count = 0 And hyperlien c contient "\test a valider\" Then

Mais je en sais pas traduite le texte en rouge en code ... :-(
 
Dernière édition:
Vote positif 0 Vote négatif
S

Softmama

XLDnaute Accro
Re : Macro recherche de fichiers en fonction de chemin,texte,extension

heu ceci dit, c'est pas compatible avec la condition:
VB: 
c.Hyperlinks.Count = 0

Je pense que ce que tu cherches à faire serait plutôt ceci :
VB: 
If c <> "" And Left(c, 1) = "1" Then
  If  c.Hyperlinks.Count = 0 Then
     '... traiter
  elseif instr(c.hyperlinks(1).address, "\test a valider\") > 0 Then
     '..traiter
  end if
end if

en collant Traiter dans une sub à part
 
Vote positif 0 Vote négatif
S

Softmama

XLDnaute Accro
Re : Macro recherche de fichiers en fonction de chemin,texte,extension

ben oui, c'est ce que je t'ai dit au post précédent : tu veux d'une part pour traiter la cellule, qu'il n'y ait pas déjà de lien (c.Hyperlinks.Count = 0) et aussi que l'adresse du lien comprenne \test a valider\ (InStr(c.Hyperlinks(1).Address, "\TEST A VALIDER\") > 0 ) ... Ca n'est pas compatible. Par ailleurs, attention car tu avais noté en minuscule dans le post précédent et dans la macro tu l'as mis en majuscule, la casse a son importance comme c'est formulé. Pour se passer de la casse, note ainsi :
InStr(ucase(c.Hyperlinks(1).Address), "\TEST A VALIDER\") > 0
 
Vote positif 0 Vote négatif
E

Emmanuel31

XLDnaute Occasionnel
Re : Macro recherche de fichiers en fonction de chemin,texte,extension

Je ne saurais pas le faire ...
Je regarde des tutoriels mais ça à pas l'air simple ...

Après je me dis qu'une barre de progression va p'tet consommer de la mémoire et du proc et donc du temps, tout ça pour afficher une barre défilante ...

P'tet que je vais uniquement afficher un UserForm avec un texte genre "traitement en cours" et fermer ce UserForm une fois terminé pour afficher une MsgBox comme quoi c'est terminé ...

Qu'en penses-tu ?
 
Dernière édition:
Vote positif 0 Vote négatif
S

Softmama

XLDnaute Accro
Re : Macro recherche de fichiers en fonction de chemin,texte,extension

Ben cette une bonne solution cet userform (à afficher en non modal). T'y colle un label dedans et tu ajoutes cette ligne de code :

Au départ:
VB: 
Userform1.show 0

et à chaque changement de c, Avant la ligne
VB: 
If c <> "" And Left(c, 1) = "1" Then
tu ajoutes :
VB: 
Userform1.Label1.Caption = "% effectué : " & 100 * (c.row - 6) / ( d.row - 6)

Puis en fin de macro
VB: 
Unload Userform1
 
Vote positif 0 Vote négatif
E

Emmanuel31

XLDnaute Occasionnel
Re : Macro recherche de fichiers en fonction de chemin,texte,extension

Merci pour l'info ...

Mais je dois louper quelque chose ...

Voici mon code :

VB: 
Sub MAJ()
   
  'Appelle la procédure de recherche des fichiers
UserForm1.Show 0
 ListeFichiers [Parametres!A2]
Unload UserForm1
  MsgBox "Mise à jour des liens terminée"
End Sub
Sub ListeFichiers(Repertoire As String)
 
 'Nécessite d'activer la référence "Microsoft Scripting RunTime"
     'Dans l'éditeur de macros (Alt+F11):
     'Menu Outils
     'Références
     'Cochez la ligne "Microsoft Scripting RunTime".
     'Cliquez sur le bouton OK pour valider.

    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim c As Range, d As Range
   
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
   
Set c = [A1]: Set d = [A500].End(xlUp)(2, 1)
'Boucle sur tous les noms de fichiers de la colonne A
Do While c.Address <> d.Address
    
'Si la cellule n'est pas vide et dont la valeur commence par un "1"
If c <> "" And Left(c, 1) = "1" Then
UserForm1.Label1.Caption = "% effectué : " & 100 * (c.Row - 6) / (d.Row - 6)
For Each FileItem In SourceFolder.Files
  'Si la cellule ne contient pas de lien hypertexte
  If c.Hyperlinks.Count = 0 Then
        If FileItem.Name Like "*" & c & "*" & [Parametres!A4] Then
            'Ajoute un lien hypertexte vers le fichier
         ActiveSheet.Hyperlinks.Add Anchor:=c, _
              Address:=FileItem.ParentFolder & "\" & FileItem.Name
        End If
  'Si la cellule contient un lien hypertexte contenant le chemin "TEST A VALIDER"
  ElseIf InStr(c.Hyperlinks(1).Address, "\TEST A VALIDER\") > 0 Then
        If FileItem.Name Like "*" & c & "*" & [Parametres!A4] Then
            'Remplace le lien hypertexte vers le chemin définitif
         ActiveSheet.Hyperlinks.Add Anchor:=c, _
              Address:=FileItem.ParentFolder & "\" & FileItem.Name
        End If
 End If
 Next FileItem
End If
    Set c = c(2, 1)
Loop
   
    '--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
 For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder
 
End Sub

Et au final j'ai un userform "vide" (voir fichier joint)
 

Pièces jointes

  • UserForm1.JPG
    UserForm1.JPG
    7.1 KB · Affichages: 37
  • UserForm1.JPG
    UserForm1.JPG
    7.1 KB · Affichages: 39
  • UserForm1.JPG
    UserForm1.JPG
    7.1 KB · Affichages: 43
Vote positif 0 Vote négatif
S

Softmama

XLDnaute Accro
Re : Macro recherche de fichiers en fonction de chemin,texte,extension

Bonjour,
Tu as bien mis un label dans ton userform. Il s'appelle bien label1 ?? La couleur de police de ce label est bien différente de celle du fond ??
Essaie cette modification, sinon :

VB: 
Sub MAJ()
   
  'Appelle la procédure de recherche des fichiers
UserForm1.Show 0
 ListeFichiers [Parametres!A2]
Unload UserForm1
  MsgBox "Mise à jour des liens terminée"
End Sub
Sub ListeFichiers(Repertoire As String)
 
 'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    'Dans l'éditeur de macros (Alt+F11):
    'Menu Outils
    'Références
    'Cochez la ligne "Microsoft Scripting RunTime".
    'Cliquez sur le bouton OK pour valider.

    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim c As Range, d As Range
   
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)
   
Set c = [A1]: Set d = [A500].End(xlUp)(2, 1)
'Boucle sur tous les noms de fichiers de la colonne A
Do While c.Address <> d.Address
  UserForm1.Label1.Caption = "% effectué : " & 100 * (c.Row - 6) / (d.Row - 6)
  Userform1.Repaint
   
'Si la cellule n'est pas vide et dont la valeur commence par un "1"
If c <> "" And Left(c, 1) = "1" Then
For Each FileItem In SourceFolder.Files
  'Si la cellule ne contient pas de lien hypertexte
 If c.Hyperlinks.Count = 0 Then
        If FileItem.Name Like "*" & c & "*" & [Parametres!A4] Then
            'Ajoute un lien hypertexte vers le fichier
        ActiveSheet.Hyperlinks.Add Anchor:=c, _
              Address:=FileItem.ParentFolder & "\" & FileItem.Name
        End If
  'Si la cellule contient un lien hypertexte contenant le chemin "TEST A VALIDER"
 ElseIf InStr(UCase(c.Hyperlinks(1).Address), "\TEST A VALIDER\") > 0 Then
        If FileItem.Name Like "*" & c & "*" & [Parametres!A4] Then
            'Remplace le lien hypertexte vers le chemin définitif
        ActiveSheet.Hyperlinks.Add Anchor:=c, _
              Address:=FileItem.ParentFolder & "\" & FileItem.Name
        End If
 End If
 Next FileItem
End If
    '--- Appel récursif pour lister les fichier dans les sous-répertoires ---.
For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
Next SubFolder
     Set c = c(2, 1)
Loop
   

End Sub

Tiens-moi au courant de ce que ça donne.
 
Dernière édition:
Vote positif 0 Vote négatif
E

Emmanuel31

XLDnaute Occasionnel
Re : Macro recherche de fichiers en fonction de chemin,texte,extension

Oula ....

Ça "marche" dans le sens ou je vois bien le UserForm avec un truc qui défile dedans ...

Mais ça défile de 0 à 100% (avec près de 15-20 décimales) puis ça passe à genre -2% (ou -3) puis ça refait jusqu’à 100% etc ...

Et j'ai l'impression que ça mets plus de temps qu'à l'accoutumée !
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

J
  • Question
Microsoft 365 Conversion de fichiers word en pdf / VBA
Réponses
1
Affichages
183
kiki29
kiki29
CISCO
  • Question
Microsoft 365 VBA : Transformer une liste de textes en liens.
Réponses
2
Affichages
231
CISCO
CISCO
Z
  • Question
Microsoft 365 Chemin pour atteindre le stockage cloud lors d'une génération de fichier Excel
Réponses
2
Affichages
259
zedude
Z
W
  • Question
Microsoft 365 VBA: Combiner/Compiler des fichiers PDF dans un chemin existant dans ordre
Réponses
2
Affichages
212
kiki29
kiki29
D
  • Question
Microsoft 365 Couper Coller Fichiers en VBA
Réponses
3
Affichages
297
patricktoulon
patricktoulon
I
  • Question
Microsoft 365 Renommer des fichiers avec des caractères non reconnus
Réponses
10
Affichages
441
ivan27
I
J
  • Question
Microsoft 365 Gestion des liens d'enregistrement
2
Réponses
21
Affichages
628
julien1982
J
E
  • Question
XL 2010 problème macro qui désactive le pavé numérique
2
Réponses
18
Affichages
592
Dranreb
Dranreb
K
  • Question
Microsoft 365 Mise en forme conditionnelle [Texte ET Date]
Réponses
5
Affichages
704
Cousinhub
Cousinhub
M
  • Question
XL 2010 macro pour mise en forme avec fichier texte
2
Réponses
17
Affichages
622
patricktoulon
patricktoulon

Membres actuellement en ligne

12 membres et 65 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 206
Messages
2 086 223
Membres
103 159
dernier inscrit
FBallea