XL 2016 Comment passer une information entre procédure par une variable

sylvanu à dit:

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 :

Code:

CheminFichierDépart = Workbooks(ActiveWorkbook.Name).Path & "\"

Cliquez pour agrandir...

dysorthographie à dit:

bonsoir,
CheminFichierDépart = Workbooks(ActiveWorkbook.Name).Path & "\"

Code:

CheminFichierDépart = ActiveWorkbook.Path & "\"

Cliquez pour agrandir...

patricktoulon à dit:

re bonsoir

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
Regarde la pièce jointe 1130879

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 minet soit 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

démonstration

à ben oui c'est plus rapide d'un coup

Regarde la pièce jointe 1130880


j'ai bien travailler moi je m'en vais me collationer dans la poire quelque victuaille satisfaisant mon appetit
a plus

Cliquez pour agrandir...

patricktoulon à dit:

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

Cliquez pour agrandir...