Couper coller tous les fichiers d'un dossier vers

[carlos]

Bonjour
je n'arrive pas à trouver le code qui me permettrait de couper tous les fichiers ( images) contenus dans un répertoire (2 niveaux) pour les coller vers un autre dossier unique.
Merci
Carlos

 

[carlos]

Bonjour,
voici une reponse
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 "C:\CD_ECOLE\CLASSE_SCONET\", 0
End Sub

Sub copie()
Dim cell As Range
Dim NomFich As String
Dim OldRep As String, NewRep As String
For Each cell In Range("a1:a" & Range("a6500").End(xlUp).Row)
OldRep = cell.Value & "\"
NewRep = "C:\PHOTO CLASSE\"

NomFich = Dir(OldRep & "*.jpg", 2)
Do While NomFich <> ""
If (GetAttr(OldRep & NomFich) And vbNormal) = vbNormal Then
FileCopy OldRep & NomFich, NewRep & NomFich
End If
NomFich = Dir()
Loop
Next cell
End Sub
Bonne journée
carlos