Comment Copier chaque fichier d'un dossier vers Onglet(s)

Merci pour votre Aide sur le sujet suivant.

J'ai un répertoire qui ce remplie avec des extracts dont le nom est aléatoires [Date Heure xxxxx PRD.xlsx]

Le nombre de fichier présent est lui aussi aléatoire

Le but de ma requête est de récupérer tout les fichiers présent de ce répertoire vers mon classeur.

Ci-joint une version Manuel que je voudrai automatisé

Merci de votre Aide

Bien cordialement

Sub RecupDatas()

'

' RecupDatas Macro

'

' recup Chaque Fichier PRD présent

Workbooks.Open Filename:= _

"C:\Users\ARC-EN-CIEL\Desktop\Répertoire Extract\20150513_001916612_WK519643_PRD.xlsx"

Sheets("20150513_001916612_WK519643_PRD").Select

Sheets("20150513_001916612_WK519643_PRD").Copy After:=Workbooks( _

"DnsAutoSource.xlsx").Sheets(3)

'

Workbooks.Open Filename:= _

"C:\Users\ARC-EN-CIEL\Desktop\Répertoire Extract\20150513_003650717_WK519640_PRD.xlsx"

Sheets("20150513_003650717_WK519640_PRD").Select

Sheets("20150513_003650717_WK519640_PRD").Copy After:=Workbooks( _

"DnsAutoSource.xlsx").Sheets(3)

'Cloture les fichiers Sources Ouvert

Windows("20150513_001916612_WK519640_PRD.xlsx").Activate

ActiveWorkbook.Close

Windows("20150513_003650717_WK519643_PRD.xlsx").Activate

ActiveWorkbook.Close

End Sub

Bonjour à toi aussi !

Une piste à adapter :

Sub RecupDatas()

    Dim Classeur As Workbook
    Dim Fe As Worksheet
    Dim Tbl() As String
    Dim Chemin As String
    Dim I As String

    Chemin = "C:\Users\ARC-EN-CIEL\Desktop\Répertoire Extract\"

    'récup des noms des fichiers
    Tbl() = Fichiers(Chemin)

    'si le tableau n'est pas vide
    If Not Not Tbl() Then

        Application.ScreenUpdating = False

        'boucle...
        For I = 1 To UBound(Tbl())

            'ouvre le classeur
            Set Classeur = Workbooks.Open(Chemin & Tbl(I))

            'recherche la ou les feuilles ayant un nom contenant la chaine "WK519640_PRD" et la copie
            For Each Fe In Classeur.Worksheets

                If InStr(Fe.Name, "WK519640_PRD") <> 0 Then Fe.Copy , Workbooks("DnsAutoSource.xlsx").Sheets(3)

            Next Fe

            'ferme
            Classeur.Close

        Next I

        Application.ScreenUpdating = True

    End If

End Sub

Function Fichiers(Chemin As String) As String()

    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer

    Fichier = Dir(Chemin & "*xlsx")

    Do While (Len(Fichier) > 0)

        I = I + 1
        ReDim Preserve TableauFichiers(1 To I)
        TableauFichiers(I) = Fichier
        Fichier = Dir()

    Loop

    Fichiers = TableauFichiers()

End Function

Merci pour ton aide, mais j'ai du mal car j'ai l'impression que Excel ne comprends pas les commandes

j'ai des erreurs de compilation !!!!

Cordialement et encore Merci