Extraire fichier Excel de plusieur dossier

Salut j'ai un dossier appeler site et a l'intérieur de se dossier j'ai plusieurs sous dossier qui contienne plusieurs document.

j'aimerais extraire tout les fichier excel qui sont dans les sous dossier du premier fichier nommé site.

si cela est possible j'aimerais qu'il ne garde que les fichier excel don le nom comporte 4 caractères.

le nom des fichier excel que je désire gardé est le même nom que le dossier

exemple

site abcd. abcd.xls

cede. cede.xls

dele dele.xls

après manipulation

site 2 abcd.xls

cede.els

dele.xls

il ne reste qu'un dossier et les fichier xls qui m'interesse

merci

Bonjour,

à tester, (note il faut adapter les répertoire)

Sub Liste_fichiers_deDossier_et_deSousDossier()
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    Dim Dossier As String
    Dossier = "C:\Users\isabelle\Pictures\" 'à adapter
    ListeFichiers Dossier
End Sub

Sub ListeFichiers(Repertoire As String)
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
    Dim Fso As Scripting.FileSystemObject
    Dim SourceFolder As Scripting.Folder
    Dim SubFolder As Scripting.Folder
    Dim FileItem As Scripting.File
    Dim i As Long
    Dim SourceFile, DestinationFile

    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)

    i = Cells(Rows.Count, 1).End(xlUp).Row + 1

    For Each FileItem In SourceFolder.Files
     rep = Split(FileItem.ParentFolder, "\")
     fichier = Split(FileItem.Name, ".")

     If fichier(LBound(fichier)) = rep(UBound(rep)) Then
      SourceFile = FileItem.ParentFolder & "\" & FileItem.Name         ' Définit le nom du fichier source.
      DestinationFile = "C:\Users\isabelle\Documents\" & FileItem.Name ' à adapter,  Définit le nom du fichier cible
      FileCopy SourceFile, DestinationFile                             ' Copie le fichier source dans le fichier cible.
     End If

        i = i + 1
    Next FileItem

    For Each SubFolder In SourceFolder.SubFolders
        ListeFichiers SubFolder.Path
    Next SubFolder

End Sub