XL 2016 Parcourir répertoire racine et ses sous répertoires

[pepeboy]

Bonjour,
J'ai créer une macro qui parcours le répertoire racine et récupère des données dans des fichiers .xlsm fermés. Celle-ci fonctionne sans problème.
Je souhaite désormais adapter cette macro en prenant en compte que :
- de chaque sous répertoire balayés je veux récupérer les données du fichier le plus récemment créé
- les fichiers sont dans plusieurs sous répertoires du répertoires racine et avec 2 sous niveaux

En création de macro, n'étant pas un virtuose de VBA, je procède en général par étape. j'ai fait la première partie, je poursuis donc.
Là je bloque sur du simple je pense ...
j'ai des répertoires comme suit:

racine\xxx\02-chiffrage\*.xlsm
racine\yyy\chiffrage\*.xlsm
racine\zzz\05-Chiffrages\*.xlsm

xxx, yyy .... sont dés répertoires avec des noms différents
le sous répertoire qui suit contient toujours "chiffrage" mais entouré de divers autres caractères
Il y a plusieurs fichiers dans le répertoire final, je veux récupérer le xlsm le plus récent.

Quand je remplace xxx par le caractère étoile (*), j'ai essayé ceci

p = ThisWorkbook.Path & "\*\*chiffrage*\"

, ça ne marche pas.

Le code ma macro existante est ci-dessous

Dim col As Integer, p As String, nomfich As String
Application.ScreenUpdating = False 'fige l'écran (pour accélérer)
Range("b1:aa50").ClearContents 'efface la plage de restitution
Range("b5:aa5").ClearComments 'efface les commentaires de la ligne 5
col = 2 'restitution à partir de la ligne 2 (si titres en ligne 1)
p = ThisWorkbook.Path & "\"
nomfich = Dir(p & "*.xlsm") '1er fichier du dossier
While nomfich <> ""
  If nomfich <> ThisWorkbook.Name Then
    Cells(5, col).Value = "='" & p & "[" & nomfich & "]Main page'!d2"
    Cells(5, col).AddComment
    Cells(5, col).Comment.Text Text:=nomfich
    Cells(6, col).Value = "='" & p & "[" & nomfich & "]Main page'!C2"
    col = col + 1
  End If
  nomfich = Dir 'fichier suivant du dossier
Wend
    'remplacer les formules de la feuille par des valeurs
    With ActiveSheet.UsedRange
        .Value = .Value
    End With
Application.ScreenUpdating = True
End Sub

Pour votre aide SVP, dans un premier temps sur comment utiliser les **** ou autres pour indiquer que les répertoires peuvent présenter différents noms.
Merci par avance

 

[D.D.]

Bonjour.

Tu as quelle version d'Excel ? Tu as PowerQuery en Addon ou natif ? Car ce dernier est capable de t'établir une liste de répertoires et sous-repertoires.

 

[pepeboy]

Bonjour, j'ai excel 2016; avec PowerPivot mais pas Query

 

[patricktoulon]

Bonsoir
en pur vba voici une fonction récursive qui te liste les fichiers avec extension demandées ou tout fichier si argument ext omis

Function liste_mes_Fichiers(path As String, Optional T As Variant = Null, Optional ExT As Variant = 0, Optional a As Long = 0)
    Dim itemVU As String, folder As Variant, dirCollection As Collection, i As Long
    Set dirCollection = New Collection
    If IsNull(T) Then T = Array()
    crit = vbDirectory Or vbHidden Or vbNormal Or vbArchive Or vbReadOnly Or vbSystem Or vbVolume
    On Error GoTo passe
    itemVU = Dir(path, crit)
  
    Do Until itemVU = vbNullString  'Explore le dossier courant (path)
         If Left(itemVU, 1) <> "." And Not path Like "*RECYCLE*" Then
            If (GetAttr(path & itemVU) And vbDirectory) <> vbDirectory Then
                 If IsArray(ExT) Then
                    For i = 0 To UBound(ExT)
                        If itemVU Like "*" & ExT(i) Then
                            ReDim Preserve T(0 To a): T(a) = path & itemVU: a = a + 1:
                        End If
                    Next
                Else
                    ReDim Preserve T(0 To a): T(a) = path & itemVU: a = a + 1:
                End If
            End If
        End If
        'ajout des dossiers enfant direct de la racine precedente  a la collection
        If Left(itemVU, 1) <> "." And (GetAttr(path & itemVU) And vbDirectory) = vbDirectory Then
            dirCollection.Add itemVU
        End If
        itemVU = Dir()
    Loop
passe:
Err.Clear
    'Exploration des subdossier inscrit dans la collection
    For Each folder In dirCollection
        'Debug.Print "---SubDirectory: " & directory & "---"
        liste_mes_Fichiers path & folder & "\", T, ExT, a
    Next folder
    liste_mes_Fichiers = T
End Function
Sub Test()
    tabl = liste_mes_Fichiers("d:\", ExT:=Array(".mp4", ".avi", ".ts", ".flv"))  ' EXTENTION DEMANDE
    Cells(1, 1).Resize(UBound(tabl), 1) = Application.Transpose(tabl) 'inscription sur sheet
End Sub

j'en ai deux ou trois comme ca si vous voulez
et il y en a quelques unes sur le net encore meilleures que la mienne
tapez liste recursive fichers vba sur google

 

[pepeboy]

Merci Patrick, je vais creuser ce code.
Nathalie, j'ai regardé avec power query mais je souhaite plutôt rester dans le VBA.

 

[D.D.]

Nathalie, j'ai regardé avec power query mais je souhaite plutôt rester dans le VBA.

Je comprends, moi aussi en principe.
(et je ne suis pas Nathalie, ca doit être une autre... )

 

[pepeboy]

Bonjour,
Patrick, j'exploite ton code qui fonctionne très bien, merci beaucoup j'avance bien.
je ne parviens pas à l'adapter afin
- d'ajouter la date de dernière modification du fichier, DateLastModifified
- d'inscrire les 3 données récoltées pour chaque fichier (chemin, nom fichier et date) en colonne A puis B puis C.
Chemin en A1, nom en A2, date en A3.

Merci
nota: D.D, désolé pour l'erreur (Nathalie...).