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