Vous utilisez un navigateur obsolète. Il se peut que ce site ou d'autres sites Web ne s'affichent pas correctement. Vous devez le mettre à jour ou utiliser un navigateur alternatif.
XL 2016Comment passer une information entre procédure par une variable
j'ai recuperé ce code du grand (Boisgontier Jacques) :
Sub TousLesDossiers(LeDossier$, Idx As Long)
Dim fso As Object, Dossier As Object
Dim sousRep As Object, Flder As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set Dossier = fso.GetFolder(LeDossier)
'examen du dossier courant
For Each Flder In Dossier.subfolders
Idx = Idx + 1
Cells(Idx, 1).Value = Flder.Path
Next
'traitement récursif des sous dossiers
For Each sousRep In Dossier.subfolders
TousLesDossiers sousRep.Path, Idx
Next sousRep
Set fso = Nothing
End Sub
'fs
Sub test()
TousLesDossiers "D:\LUI\Developement\VB_VBA\", 0
End Sub
j'aimerais au lieu d'ecrire l'adresse manuellement (celle en vert) mettre a la place une variable contenant un chemin enregistré au préalable :
je vous avoue que j'ai testé c'es deux cas mais aucun ne marche :
TousLesDossiers CheminFichierDépart, 0 " la le programme stop directe
TousLesDossiers "CheminFichierDépart", 0 " la le programme passe a la procedure ("Sub TousLesDossiers(LeDossier$, Idx As Long)") et stop a la ligne : Set Dossier = fso.GetFolder(LeDossier)
si vous aviez une idée je suis preneur, merci d'avance
1° j'avoue que même si ça avait été codé correctement( corrigé par mes camarades) je ne comprends pas la relation avec un self path et un chemin enregistré préalablement quelque part c'est quoi le rapport
Bonsoir TaigaLupus,
Normalement "TousLesDossiers CheminFichierDépart, 0" devrait marcher si le chemin est correct.
testez :
VB:
Sub test()
CheminFichierDépart = Workbooks(ActiveWorkbook.Name).Path
MsgBox "Le chemin devrait être : D:\LUI\Developement\VB_VBA\" & Chr(10) & _
"Celui tranféré est : " & CheminFichierDépart
TousLesDossiers CheminFichierDépart, 0
End Sub
Il est possible qu'il manque un "\" à la fin. Dans ce cas faites :
1° j'avoue que même si ça avait été codé correctement( corrigé par mes camarades) je ne comprends pas la relation avec un self path et un chemin enregistré préalablement quelque part c'est quoi le rapport
peut être voulais tu dire automatiquement le même dossier de départ que le classeur lui même
au quel cas c'est bien thisworkbook.path
2°
faut pas oublier que FSO est aussi lourd que facile à utiliser contrairement à (DIR)qui est plus complexe a mettre en récurif dans une sub ou fonction
3° hahhh! on y viens
une sub ou fonction récursive à ça c'est une bonne idée
sauf que quand elle n'est pas bien mis en place et bien c'est compliqué
et justement avec FSO le gros lourdo on a là un exemple parfait
pour commencer je dirais que l'exemple donné par @TaigaLupus
issue des tutos de notre regretté Jacques Boigontiers est a but école(un principe de base )
et non une macro prête à l'emplois et optimisée pour/et en toute les circonstance
les pièges d'une sub ou fonction récursive avec FSO
les variables a transporter dans le looping (début macro/rappel macro) dans l'exemple ici présent je parle de la variable idx
des variables (ET là c'est important ) qui au mieux !!!sont chargées a chaque tour
comme le gros lourdo(vous voyez du quel je parle) mais PAS DECHARGEE !!!! même si vous avez un is nothing en fin de macro
et oui c'est là ou le bas blesse
IL FAUT SAVOIR ;une fonction récursive avec FSO commençant sur un dossier tourne autant de fois que de dossier et sous dossier ET REVIENT A SON POINT DE DÉPART !!!!!et non successivement d'un dossier à l'autre
concrètement ça se représente comment
imaginons un dossier du nom de "toto"
dans ce dossier il y a 2 dossiers titi et grosminet
dans ces deux sous dossiers j'ai deux autres sous dossiers
dans titi j'ai riri et fifi et dans grosminet j'ai loulou et bidule
disons que je schématise
alors comment ça marche
et bien en fait
chaque cession de la sub reste ouverte!!!!!!
TANT QUE LA SESSION SUIVANTE N A pas FINI QUI ELLE MÊME RESTE OUVERTE TANT QUE SA SUIVANTE N a pas fini
toto trouve titi et grosminet deux autres cessions
quand titi ou grosminet est lancé toto n'est pas fermée puis que c'est elle qui a fait le rappel il faut qu'elle attende donc que l'instance de la macro pour titi et gros minetsoit finie et elle va attendre longtemps puisque ces deux dernières lancent a leur tour riri et fifi d'un coté et loulou et bidule de l'autre
on est donc quand on en est au plus profond de l'arborescence à 5 créations ouverte de FSo sur les derniers sous dossier
en effet quand on est dans bidule forcement loulou est fini et pareil pour son cousin a gauche
imaginez vous une arborescence de 10 sous dossier fois 10 sous dossiers
et malgré tout ça le gros lourdo de FSO ne perd pas un grame
concrètement comment corriger le problème
et bien pour commencer le FSO 1° le FSO sera une variable public ou globale module 2° il sera instancié uniquement si il est nothing(une seule fois!!) pour tout la tournée 3° on le décharge quand vraiment la sub a fini ( avec un pointeur de fin )
on a donc une seule instance de l'object ben là mon procc se sent mieux et la mémoire aussi
ensuite
4° on envoie la liste cellule par cellule alors que l'on pourrait charger la liste dans une variable tableau pour la décharger à la fin
mais comment garder en mémoire la liste
et bien comme je disais plus haut on a la solution de balader les variable de la même manière que idx
sauf que si on a des tris ou modif a faire ça deviens vite la bérésina alors on opte pour des variable static elle ont l'avantage d’être déclarée dans la sub tout en restant chargées entre les tours de looping récursif
alors concrètement comment pointer le début et la fin ???
être ou ne pas être tel est la question
et bien c'est simple on en a un déjà avec idx=0 au départ
oui mais on sait pas combien il y a de dossiers on ne sait donc pas quand ça va s’arrêter
et bien sur que si on le sait !!!!!!!!
rappelez vous je cite ce que je vous ai dis plus haut
IL FAUT SAVOIR ;une fonction récursive avec FSO commençant sur un dossier tourne autant de fois que de dossier et sous dossier ET REVIENT AS ON POINT DE DEPART !!!!!et non successivement d'un dossier à
alors on peut faire quoi avec ça ??
ben c'est tout simple
en fin de sub si idx>0 and ledossier = le first dossier ben ça veux dire que notre gros lourdo de fso a fini
quand on a ces deux conditions ,on est sur à 100% que toute l’arborescence a été visité sauf erreur dossier protégé ou System et même là!!!! l'erreur 52 et 72 se gère facilement
alors voilà la sub récursive tel que je la conçoit
1 FSO déclaré en haut de module
2 on met le idx en argument optional on peut donc omettre d'envoyer l'argument au départ
3 on créé 2 variable static
tbl() notre variable array
firsdossier le pointeur string du premier dossier de départ
4 correction de dernier shach sur le nom du dossier
5 création de l'instance fso si = nothing
6 on instancie le getfolder le dossier qui va être examiné
7° on boucle sur les dossiers enfants du dossier courant et on stocke dans l'array redimensionné dynamiquement
8 on boucle sur les sub folder et on rappelle la sub avec idx a jour
et ca tourne etc...........
9 en fin de sub (avant le "end sub"
si idx>0 and ledossier =firstdossier "
on envoie larray transposé dans la feuille
on peut vider toute les variables
terminé tout le monde descends
terminé le blablabla
VB:
Dim FSO As Object 'variable globale en haut de module
Sub TousLesDossiers(LeDossier, Optional Idx As Long = 0)
Dim Dossier As Object, sousRep As Object, Flder As Object
Static tbl(): Static FirstDossier$ ' les variables tableau et string firstdossier se charge et reste chargée tant que ca tourne
'si on oublie le dernier slash ou des le 2d tour qui n'envoie que le path(""!! sousRep.Path !!"")
If Right(LeDossier, 1) <> "\" Then LeDossier = LeDossier & "\"
If Idx = 0 Then
Erase tbl 'on eraze le tableau pour une future utilisation
FirstDossier = LeDossier 'on memorise le dossier de départ (on va s'en servir de pointeur de fin )
Debug.Print LeDossier 'on le pointe dans la console pour visualiser le principe
End If
If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject") 'on ne créée qu'une fois!!!!!!!! l'object pour economiser une cration a chaque visite d'un dossier ou soudossier
End If
Set Dossier = FSO.GetFolder(LeDossier) 'on détermine dans FSO le getfolder
'c'est parti!!!
For Each Flder In Dossier.subfolders 'examen du dossier courant
Idx = Idx + 1: ReDim Preserve tbl(1 To Idx): tbl(Idx) = Flder.Path 'redimensionnement auto et inscription dans la variable tableau (tbl)du dossier en cours d'examen
Next
'traitement récursif des sous dossiers
For Each sousRep In Dossier.subfolders
TousLesDossiers sousRep.Path, Idx
Next sousRep
'ici on test si idx est > 0 et que ledossier est bien revenu à Firsdossier(le dossier de départ )
'si oui on transfert alors le tableau sinon on continue le looping
If Idx > 0 And LeDossier = FirstDossier Then
Debug.Print LeDossier
[A:A].ClearContents
[A1].Resize(UBound(tbl)) = Application.Transpose(tbl)
Firsdossier = ""
Erase tbl
Set FSO = Nothing
End If
End Sub
Sub test()
TousLesDossiers "E:\vba excel" 'mettre votre dossier avec ou sans le dernier slash on s'en fou c'est corrigé dans la sub
End Sub
démonstration
à ben oui c'est plus rapide d'un coup
j'ai bien travailler moi je m'en vais me collationer dans la poire quelque victuaille satisfaisant mon appetit
a plus
Bonsoir TaigaLupus,
Normalement "TousLesDossiers CheminFichierDépart, 0" devrait marcher si le chemin est correct.
testez :
VB:
Sub test()
CheminFichierDépart = Workbooks(ActiveWorkbook.Name).Path
MsgBox "Le chemin devrait être : D:\LUI\Developement\VB_VBA\" & Chr(10) & _
"Celui tranféré est : " & CheminFichierDépart
TousLesDossiers CheminFichierDépart, 0
End Sub
Il est possible qu'il manque un "\" à la fin. Dans ce cas faites :
1° j'avoue que même si ça avait été codé correctement( corrigé par mes camarades) je ne comprends pas la relation avec un self path et un chemin enregistré préalablement quelque part c'est quoi le rapport
peut être voulais tu dire automatiquement le même dossier de départ que le classeur lui même
au quel cas c'est bien thisworkbook.path
2°
faut pas oublier que FSO est aussi lourd que facile à utiliser contrairement à (DIR)qui est plus complexe a mettre en récurif dans une sub ou fonction
3° hahhh! on y viens
une sub ou fonction récursive à ça c'est une bonne idée
sauf que quand elle n'est pas bien mis en place et bien c'est compliqué
et justement avec FSO le gros lourdo on a là un exemple parfait
pour commencer je dirais que l'exemple donné par @TaigaLupus
issue des tutos de notre regretté Jacques Boigontiers est a but école(un principe de base )
et non une macro prête à l'emplois et optimisée pour/et en toute les circonstance
les pièges d'une sub ou fonction récursive avec FSO
les variables a transporter dans le looping (début macro/rappel macro) dans l'exemple ici présent je parle de la variable idx
des variables (ET là c'est important ) qui au mieux !!!sont chargées a chaque tour
comme le gros lourdo(vous voyez du quel je parle) mais PAS DECHARGEE !!!! même si vous avez un is nothing en fin de macro
et oui c'est là ou le bas blesse
IL FAUT SAVOIR ;une fonction récursive avec FSO commençant sur un dossier tourne autant de fois que de dossier et sous dossier ET REVIENT A SON POINT DE DÉPART !!!!!et non successivement d'un dossier à l'autre
concrètement ça se représente comment
imaginons un dossier du nom de "toto"
dans ce dossier il y a 2 dossiers titi et grosminet
dans ces deux sous dossiers j'ai deux autres sous dossiers
dans titi j'ai riri et fifi et dans grosminet j'ai loulou et bidule
alors comment ça marche
et bien en fait
chaque cession de la sub reste ouverte!!!!!!
TANT QUE LA SESSION SUIVANTE N A pas FINI QUI ELLE MÊME RESTE OUVERTE TANT QUE SA SUIVANTE N a pas fini
toto trouve titi et grosminet deux autres cessions
quand titi ou grosminet est lancé toto n'est pas fermée puis que c'est elle qui a fait le rappel il faut qu'elle attende donc que l'instance de la macro pour titi et gros minetsoit finie et elle va attendre longtemps puisque ces deux dernières lancent a leur tour riri et fifi d'un coté et loulou et bidule de l'autre
on est donc quand on en est au plus profond de l'arborescence à 5 créations ouverte de FSo sur les derniers sous dossier
en effet quand on est dans bidule forcement loulou est fini et pareil pour son cousin a gauche
imaginez vous une arborescence de 10 sous dossier fois 10 sous dossiers
et malgré tout ça le gros lourdo de FSO ne perd pas un grame
concrètement comment corriger le problème
et bien pour commencer le FSO 1° le FSO sera une variable public ou globale module 2° il sera instancié uniquement si il est nothing(une seule fois!!) pour tout la tournée 3° on le décharge quand vraiment la sub a fini ( avec un pointeur de fin )
on a donc une seule instance de l'object ben là mon procc se sent mieux et la mémoire aussi
ensuite
4° on envoie la liste cellule par cellule alors que l'on pourrait charger la liste dans une variable tableau pour la décharger à la fin
mais comment garder en mémoire la liste
et bien comme je disais plus haut on a la solution de balader les variable de la même manière que idx
sauf que si on a des tris ou modif a faire ça deviens vite la bérésina alors on opte pour des variable static elle ont l'avantage d’être déclarée dans la sub tout en restant chargées entre les tours de looping récursif
alors concrètement comment pointer le début et la fin ???
être ou ne pas être tel est la question
et bien c'est simple on en a un déjà avec idx=0 au départ
oui mais on sait pas combien il y a de dossiers on ne sait donc pas quand ça va s’arrêter
et bien sur que si on le sait !!!!!!!!
rappelez vous je cite ce que je vous ai dis plus haut
alors on peut faire quoi avec ça ??
ben c'est tout simple
en fin de sub si idx>0 and ledossier = le first dossier ben ça veux dire que notre gros lourdo de fso a fini
quand on a ces deux conditions ,on est sur à 100% que toute l’arborescence a été visité sauf erreur dossier protégé ou System et même là!!!! l'erreur 52 et 72 se gère facilement
alors voilà la sub récursive tel que je la conçoit
1 FSO déclaré en haut de module
2 on met le idx en argument optional on peut donc omettre d'envoyer l'argument au départ
3 on créé 2 variable static
tbl() notre variable array
firsdossier le pointeur string du premier dossier de départ
4 correction de dernier shach sur le nom du dossier
5 création de l'instance fso si = nothing
6 on instancie le getfolder le dossier qui va être examiné
7° on boucle sur les dossiers enfants du dossier courant et on stocke dans l'array redimensionné dynamiquement
8 on boucle sur les sub folder et on rappelle la sub avec idx a jour
et ca tourne etc...........
9 en fin de sub (avant le "end sub"
si idx>0 and ledossier =firstdossier "
on envoie larray transposé dans la feuille
on peut vider toute les variables
terminé tout le monde descends
terminé le blablabla
VB:
Dim FSO As Object 'variable globale en haut de module
Sub TousLesDossiers(LeDossier, Optional Idx As Long = 0)
Dim Dossier As Object, sousRep As Object, Flder As Object
Static tbl(): Static FirstDossier$ ' les variables tableau et string firstdossier se charge et reste chargée tant que ca tourne
'si on oublie le dernier slash ou des le 2d tour qui n'envoie que le path(""!! sousRep.Path !!"")
If Right(LeDossier, 1) <> "\" Then LeDossier = LeDossier & "\"
If Idx = 0 Then
Erase tbl 'on eraze le tableau pour une future utilisation
FirstDossier = LeDossier 'on memorise le dossier de départ (on va s'en servir de pointeur de fin )
Debug.Print LeDossier 'on le pointe dans la console pour visualiser le principe
End If
If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject") 'on ne créée qu'une fois!!!!!!!! l'object pour economiser une cration a chaque visite d'un dossier ou soudossier
End If
Set Dossier = FSO.GetFolder(LeDossier) 'on détermine dans FSO le getfolder
'c'est parti!!!
For Each Flder In Dossier.subfolders 'examen du dossier courant
Idx = Idx + 1: ReDim Preserve tbl(1 To Idx): tbl(Idx) = Flder.Path 'redimensionnement auto et inscription dans la variable tableau (tbl)du dossier en cours d'examen
Next
'traitement récursif des sous dossiers
For Each sousRep In Dossier.subfolders
TousLesDossiers sousRep.Path, Idx
Next sousRep
'ici on test si idx est > 0 et que ledossier est bien revenu à Firsdossier(le dossier de départ )
'si oui on transfert alors le tableau sinon on continue le looping
If Idx > 0 And LeDossier = FirstDossier Then
Debug.Print LeDossier
[A:A].ClearContents
[A1].Resize(UBound(tbl)) = Application.Transpose(tbl)
Firsdossier = ""
Erase tbl
Set FSO = Nothing
End If
End Sub
Sub test()
TousLesDossiers "E:\vba excel" 'mettre votre dossier avec ou sans le dernier slash on s'en fou c'est corrigé dans la sub
End Sub
Bonjour, vraiment merci , par contre j'en ai pour la semaine a tous comprendre ton post. sinon mon but et de lister les sous dossier et d'ouvrir le fichier excel contenu dans des dossier ayant toujours le même noms et ensuite de recuperer les données d'un onglet du fichier excel dans un registre...mais autant sur excel classique je suis bon (si si ) autant je bidouille sur vba.... donc un grand merci pour toutes ces explications
Bonjour
dans ce cas là tu a la possibilité de lister uniquement les noms de fichier directement
et toujours en récursif et on peut même argumenter juste la partie d'un nom sie les dit fichier ont un prefixe identique mais que la fin du nom est différente
après comme je l'ai plus ou mins dit attention avec fso il faut les garde fou du genre la correction du dernier slash
il faudrait aussi inclure les erreur 52 53 72 du au fichier avec nom trop long et ou avec des caractères particuliers
DuDU et moi avons mis au point justement une fonction list avec FSO gérant tout ca
tiens la voila la fso récursive sur fichiers
VB:
'**************************************************************
'fonction récursive pour lister les fichiers d'un disque ou dossier
'Utilisation de filesystemobject(FSO)
'-------------------------------------
' THEME
'recherche D 'amelioration pour la lenteur de FSO en récursif
'recherche des moyens de controler les erreurs du aux noms trop long ou fichiers interdit ou system ou caracteres particuliers
'------------------------------------
'Auteurs Dudu2 et patricktoulon sur exceldownload
'version 1.5
'Date:08/02/2021
'mise en place du principe (Part name) valable aussi pour (si juste extension demandée:ex;[*.XXX])
'suppression du stockage des erreurs et des msgbox d'erreur
'suppression commentaires
'utilisation d'une fonction de transposition de l'array simplifiée (horizontal(1 dim) To vertical(2 dim))pour palier au limite de la fonction transpose d'excel
'Date:08/02/2021
'accélération du processus
'en ajoutant du test dir non bloquant pour zapper les dossiers
'ne contenant pas de fichier avec l'extension ou la partie du nom demandée
'Date:13/02/2021
'remplacement du bloc <<if takeit>> par un jumping (etiquette "ScanFolder")
'pour jumper directement sur la boucle des dossiers on zappe directement la partie du code boucle ofile si pas de fichier
'****************************************************************
Option Explicit
Option Compare Text
Function TransposeArray(arr) ' fonction de transposition pour palier au limites de la fonction transpose d'excel
Dim tbl(), I&: ReDim tbl(LBound(arr) To UBound(arr), 1 To 1)
For I = LBound(arr) To UBound(arr): tbl(I, 1) = arr(I): Next
TransposeArray = tbl
End Function
'
Function FSO_List_FICHIERS2(ByVal Folder As Variant, Optional PartName As String = "") As Variant
Static tbl() As String: Static NbFichiers As Long: Static oFSO As Object
Dim oDir As Object, oSubDir As Object, oFile As Object, First_Call As Boolean, TakeIT As Boolean
If TypeOf Folder Is Object Then 'si ce nest pas le premier appel Foler est un objet folder membre de FSO
First_Call = False 'si ce nest pas le premier appel on positionne First_Call a false des les 2d appel
Set oDir = Folder 'si ce nest pas le premier appel Odir est donc un object Folder membre de FSO
Else 'si c'est le premier appel Folder est de type string
First_Call = True 'si c'est le premier appel first_call est a true
Erase tbl 'si c'est le premier appel on eraze la variable tableau <<tbl>>
NbFichiers = 0 'si c'est le premier appel on met la variables NbFichiers à 0
Set oFSO = CreateObject("Scripting.FileSystemObject") 'si c'est le premier appel on créée l'object FSO
If Right(Folder, 1) <> "\" Then Folder = Folder & "\" 'si c'est le premier appel si le slach de fin on l'ajoute
Set oDir = oFSO.getfolder(Folder) 'si c'est le premier appel on instruit l'object Folder<<Odir>>avec le string du dossier
End If
TakeIT = True 'on met la variable Takeit à true d'office
' on ouvre une gestion d'erreur globale (pour les permissions refusées ou les noms portants des caracteres speciaux)
'la gestion est valable aussi pour la boucle subFolder elle es fermé a chaque fin d'appels récursifs
On Error Resume Next
If Len(PartName) > 0 Then TakeIT = Len(Dir(oDir.Path & "\" & PartName)) > 0 'si partname demandé on test de presence de (fichier avec PartName dans le nom) dans le dossier en une seule fois
If Err.Number <> 0 Or TakeIT = False Then Err.Clear: GoSub Scanfolder ' si erreur ou TakeIt =false on zappe l'exploration des fichiers on va directement à l'exploration des sous dossiers avec gosub
For Each oFile In oDir.Files 'boucle sur les fichiers
If Err.Number = 0 Then 'si pas d'erreur
If Len(PartName) = 0 Then 'si pas de PartName demandé on memorise le fichier directement
NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path
Else 'si PartName demandé on teste si le nom de fichier like PartName
If oFile.Name Like PartName Then NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path 'Stocke le nom complet du fichier en table
End If
End If
Err.Clear ' on clear l'erreur au cas ou
Next oFile
Scanfolder: ' etiquette du jumping d'exploration
For Each oSubDir In oDir.subfolders ' boucle sur les dossiers
If Err.Number = 0 Then
FSO_List_FICHIERS2 oSubDir, PartName ' on relance la fonction ( appel récursif)
Else: Err.Clear ' sinon on clear l'erreur si dossier interdit ou special
End If
Next oSubDir
On Error GoTo 0 ' ferme la gestion d'erreur globale
' si c'est le premier appel donc on a lu tout l'arborescence en appels récursifs on peut maintenant instruire le return de la fonction avec le tableau
If First_Call Then
FSO_List_FICHIERS2 = False ' on met le return de la fonction a false
If NbFichiers > 0 Then FSO_List_FICHIERS2 = tbl ' si NbFichiers est plus grand que 0 le return de la fonction est la tableau
End If
End Function
et pour l'utiliser
dans le module ou un autre module tu met par exemple
on va rechercher tout les fichiers portant dans le nom la chaine "toto"
si tu cherche des fichiers excel par exemple xlsx ou xlsm ou xltm etc et portant dans le nom la chaine"taratata"
et bien c'est Const Ext$ = "*tartata.xl*"
ca va donc te trouver tout les fichier sous toute les format d'excel
Code:
Sub listeFSOGOSUB()
Dim Table As Variant, tim
ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
Const Répertoire = thisworkbook.path
tim = Timer
Const Ext$ = "*toto.*"
Table = FSO_List_FICHIERS2(Répertoire, Ext)
If IsArray(Table) Then
Table = TransposeArray(Table)
tim = Format(Timer - tim, "#0.000 S")
MsgBox UBound(Table) & " fichier(s) <""" & Ext & """> trouvé(s) dans le répertoire <" & Répertoire & "> en " & tim & " s/"
ActiveSheet.Range("A1").Resize(UBound(Table)).Value = Table
Else
MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">" & vbCrLf & "ayant une partie du nom contenant " & Ext
End If
End Sub
voilà on se retrouve avec une fonction quasiment aussi rapide que DIR
Bonjour
dans ce cas là tu a la possibilité de lister uniquement les noms de fichier directement
et toujours en récursif et on peut même argumenter juste la partie d'un nom sie les dit fichier ont un prefixe identique mais que la fin du nom est différente
après comme je l'ai plus ou mins dit attention avec fso il faut les garde fou du genre la correction du dernier slash
il faudrait aussi inclure les erreur 52 53 72 du au fichier avec nom trop long et ou avec des caractères particuliers
DuDU et moi avons mis au point justement une fonction list avec FSO gérant tout ca
tiens la voila la fso récursive sur fichiers
VB:
'**************************************************************
'fonction récursive pour lister les fichiers d'un disque ou dossier
'Utilisation de filesystemobject(FSO)
'-------------------------------------
' THEME
'recherche D 'amelioration pour la lenteur de FSO en récursif
'recherche des moyens de controler les erreurs du aux noms trop long ou fichiers interdit ou system ou caracteres particuliers
'------------------------------------
'Auteurs Dudu2 et patricktoulon sur exceldownload
'version 1.5
'Date:08/02/2021
'mise en place du principe (Part name) valable aussi pour (si juste extension demandée:ex;[*.XXX])
'suppression du stockage des erreurs et des msgbox d'erreur
'suppression commentaires
'utilisation d'une fonction de transposition de l'array simplifiée (horizontal(1 dim) To vertical(2 dim))pour palier au limite de la fonction transpose d'excel
'Date:08/02/2021
'accélération du processus
'en ajoutant du test dir non bloquant pour zapper les dossiers
'ne contenant pas de fichier avec l'extension ou la partie du nom demandée
'Date:13/02/2021
'remplacement du bloc <<if takeit>> par un jumping (etiquette "ScanFolder")
'pour jumper directement sur la boucle des dossiers on zappe directement la partie du code boucle ofile si pas de fichier
'****************************************************************
Option Explicit
Option Compare Text
Function TransposeArray(arr) ' fonction de transposition pour palier au limites de la fonction transpose d'excel
Dim tbl(), I&: ReDim tbl(LBound(arr) To UBound(arr), 1 To 1)
For I = LBound(arr) To UBound(arr): tbl(I, 1) = arr(I): Next
TransposeArray = tbl
End Function
'
Function FSO_List_FICHIERS2(ByVal Folder As Variant, Optional PartName As String = "") As Variant
Static tbl() As String: Static NbFichiers As Long: Static oFSO As Object
Dim oDir As Object, oSubDir As Object, oFile As Object, First_Call As Boolean, TakeIT As Boolean
If TypeOf Folder Is Object Then 'si ce nest pas le premier appel Foler est un objet folder membre de FSO
First_Call = False 'si ce nest pas le premier appel on positionne First_Call a false des les 2d appel
Set oDir = Folder 'si ce nest pas le premier appel Odir est donc un object Folder membre de FSO
Else 'si c'est le premier appel Folder est de type string
First_Call = True 'si c'est le premier appel first_call est a true
Erase tbl 'si c'est le premier appel on eraze la variable tableau <<tbl>>
NbFichiers = 0 'si c'est le premier appel on met la variables NbFichiers à 0
Set oFSO = CreateObject("Scripting.FileSystemObject") 'si c'est le premier appel on créée l'object FSO
If Right(Folder, 1) <> "\" Then Folder = Folder & "\" 'si c'est le premier appel si le slach de fin on l'ajoute
Set oDir = oFSO.getfolder(Folder) 'si c'est le premier appel on instruit l'object Folder<<Odir>>avec le string du dossier
End If
TakeIT = True 'on met la variable Takeit à true d'office
' on ouvre une gestion d'erreur globale (pour les permissions refusées ou les noms portants des caracteres speciaux)
'la gestion est valable aussi pour la boucle subFolder elle es fermé a chaque fin d'appels récursifs
On Error Resume Next
If Len(PartName) > 0 Then TakeIT = Len(Dir(oDir.Path & "\" & PartName)) > 0 'si partname demandé on test de presence de (fichier avec PartName dans le nom) dans le dossier en une seule fois
If Err.Number <> 0 Or TakeIT = False Then Err.Clear: GoSub Scanfolder ' si erreur ou TakeIt =false on zappe l'exploration des fichiers on va directement à l'exploration des sous dossiers avec gosub
For Each oFile In oDir.Files 'boucle sur les fichiers
If Err.Number = 0 Then 'si pas d'erreur
If Len(PartName) = 0 Then 'si pas de PartName demandé on memorise le fichier directement
NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path
Else 'si PartName demandé on teste si le nom de fichier like PartName
If oFile.Name Like PartName Then NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = oFile.Path 'Stocke le nom complet du fichier en table
End If
End If
Err.Clear ' on clear l'erreur au cas ou
Next oFile
Scanfolder: ' etiquette du jumping d'exploration
For Each oSubDir In oDir.subfolders ' boucle sur les dossiers
If Err.Number = 0 Then
FSO_List_FICHIERS2 oSubDir, PartName ' on relance la fonction ( appel récursif)
Else: Err.Clear ' sinon on clear l'erreur si dossier interdit ou special
End If
Next oSubDir
On Error GoTo 0 ' ferme la gestion d'erreur globale
' si c'est le premier appel donc on a lu tout l'arborescence en appels récursifs on peut maintenant instruire le return de la fonction avec le tableau
If First_Call Then
FSO_List_FICHIERS2 = False ' on met le return de la fonction a false
If NbFichiers > 0 Then FSO_List_FICHIERS2 = tbl ' si NbFichiers est plus grand que 0 le return de la fonction est la tableau
End If
End Function
et pour l'utiliser
dans le module ou un autre module tu met par exemple
on va rechercher tout les fichiers portant dans le nom la chaine "toto"
si tu cherche des fichiers excel par exemple xlsx ou xlsm ou xltm etc et portant dans le nom la chaine"taratata"
et bien c'est Const Ext$ = "*tartata.xl*"
ca va donc te trouver tout les fichier sous toute les format d'excel
Code:
Sub listeFSOGOSUB()
Dim Table As Variant, tim
ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
Const Répertoire = thisworkbook.path
tim = Timer
Const Ext$ = "*toto.*"
Table = FSO_List_FICHIERS2(Répertoire, Ext)
If IsArray(Table) Then
Table = TransposeArray(Table)
tim = Format(Timer - tim, "#0.000 S")
MsgBox UBound(Table) & " fichier(s) <""" & Ext & """> trouvé(s) dans le répertoire <" & Répertoire & "> en " & tim & " s/"
ActiveSheet.Range("A1").Resize(UBound(Table)).Value = Table
Else
MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">" & vbCrLf & "ayant une partie du nom contenant " & Ext
End If
End Sub
voilà on se retrouve avec une fonction quasiment aussi rapide que DIR
Waouuu t'es un grand malade (dans le bon sens du terme evidemment) en tous cas tu es mon gourou du VBA et chaque soir j'allumerais un cierge en ton nom !!! bon maintenant il ne me reste plus qu'a tester le code et le comprendre (ouf la il ya du boulot) !!! MERCI, MERCI, MERCI
re
gourou je sais pas c'est l'expérience c'est tout
c'est @Dudu2 et moi qui avons chercher par tout les moyen à accélérer une fonction récursive avec FSO
et on a decouvert en meme temps les piges justement de la récursivité
nous divergeons un peu pour la destination de partname lui travaille surtout sur l’extension de fichier
le mien partname (ext)sert pour tout il suffit de coder la chaine comme on en a besoins avec les éléments de recherche que l'on souhaite
Const Ext$ = "*toto*blabla*.p*"
recherche tout les fichiers ayant dans le nom quelque chose et "toto" et quelque chose et "blabla" et ayant une extension commençant par "p"
il trouvera des pdf des powerpoint des plx etc.. ayant les chaines demandées dans cet ordre
vous remarquerz que nous avons inclu un dir qui n'est là que pour dire si on tourne ou pas
bref ce fut une longue discussion très enrichissante ( toujours avec @Dudu2)
nous avons passé pal mal d'heures sur ce projet
Bonjour.
Pour faire prendre en compte une expression par une procédure, passez ByVal l'argument correspondant. Ne serait-ce que pour réduire le risque d'une erreur de compilation "Type d'argument ByRef incompatible", mais aussi pour d'autres raisons à vocation documentaire, logique et technique. C'est mieux à tout point de vue.
Ce site utilise des cookies pour personnaliser le contenu, adapter votre expérience et vous garder connecté si vous vous enregistrez.
En continuant à utiliser ce site, vous consentez à notre utilisation de cookies.
on a là un exemple parfait
