'patricktoulon
'basée sur ma fonction récursive avec dir de 2016
'tout les fichiers "XXXX.txt" seront trouvé et listés
Option Explicit
Sub testXy()
'Cells.Clear
Dim liste As Variant, i&, OldDossier, newdossier
liste = listefichier("C:\Users\polux\DeskTop\dossier maitre\", partname:="XXXX", extention:=".txt")
newdossier = "C:\Users\polux\DeskTop\nouveau dossier maitre\"
'maintenant tu fait ce que tu veux avec la liste des fichiers trouvés
' exemple
'MsgBox Join(liste, vbCrLf)
For i = LBound(liste) To UBound(liste)
OldDossier = Split(liste(i), "\")(UBound(Split(liste(i), "\")) - 1)
MsgBox "le fichier s'appelle " & liste(i) & vbCrLf & "il devrait s'appeler maintenant" & vbCrLf & newdossier & OldDossier & ".txt"
'te reste plus qu'a faire un filecopy ici dans la boucle
'...
Next
End Sub
Function listefichier(Dossier As String, Optional recall As Boolean = False, Optional tbl As Variant, Optional partname As String = "*", Optional extention As String = "*") As Variant
Dim ItemVu As String, directory As Variant, SubFolderCollection As Collection, i As Long, A As Long, E As Long, subdossier
Set SubFolderCollection = New Collection
If recall = False Then ReDim tbl(0) ' si recall on redim un tableau de zero item (pour la creation du tableau)
On Error Resume Next 'gestion des fichiers dossiers system et interdit ou generant une erreur(PerLog,recycle,etc..)
ItemVu = Dir(Dossier, vbDirectory)
If Error.Number = 0 Then ' si pas d'erreur on examine le contenu
'examen du dossier courrant
Do Until ItemVu = vbNullString
If Left(ItemVu, 1) <> "." Then
If (GetAttr(Dossier & ItemVu) And vbDirectory) = vbDirectory Then
SubFolderCollection.Add ItemVu
Else
If Left(ItemVu, Len(partname)) = partname And Right(ItemVu, 4) = extention Then A = UBound(tbl) + 1: ReDim Preserve tbl(1 To A): tbl(A) = Dossier & ItemVu
End If
End If
ItemVu = Dir()
Loop
Else
Err.Clear
End If
'examen des sub dossier
For Each subdossier In SubFolderCollection
'A = UBound(tbl) + 1: ReDim Preserve tbl(1 To A): tbl(A) = Dossier & subdossier' si on veut lister les dossiers aussi
listefichier Dossier & subdossier & "\", True, tbl, partname, extention
Next subdossier
listefichier = tbl
End Function
