Regrouper plusieurs classeurs excel en Un

[naouah]

j'a i une application qui me créer plusieurs fichier Excel (chaque fichier a un nom et il contient une feulle )
j'aimerais pouvoir regrouper ces classeurs en un seul, et a chaque fois le nom de la feuille excel soit le nom de classeur.

la j'ai utilise ce code pour regrouper mais uniquement sur une seule feuille

Sub CompilationClasseurs()
Dim Repertoire As String, Fichier As String
Dim Wb As Workbook
Dim Ws As Worksheet
Dim x As Integer

Repertoire = "C:\dossier"


Application.ScreenUpdating = False

Fichier = Dir(Repertoire & "\*.xls")

Do While Fichier <> ""

Set Wb = Workbooks.Open(Repertoire & "\" & Fichier)

Set Ws = Wb.Sheets(1)
Ws.Range("A1:i2000").Copy


x = ThisWorkbook.Sheets(1).Range("A65536").End(xlUp).Row + 1


ThisWorkbook.Sheets(1).Cells(x, 1).PasteSpecial

Application.CutCopyMode = False


Wb.Close False

Fichier = Dir
Loop

Application.ScreenUpdating = True
MsgBox "Opération terminée."
End Sub

 

[jp14]

Re : Regrouper plusieurs classeurs excel en Un

Bonsoir

Ci desous la macro modifiée
Pour éviter la création de répertoire j'utilise le répertoire d'excel

Option Explicit

Sub CompilationClasseurs()
Dim Repertoire As String, Fichier As String
Dim Wb As Workbook
Dim Ws As Worksheet
Dim x As Integer
Dim classeur1 As String

Repertoire = ThisWorkbook.Path & "\"
classeur1 = ActiveWorkbook.Name
'Repertoire = "C:\dossier"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Fichier = Dir(Repertoire & "\classeurx*.xls")

Do While Fichier <> ""


Set Wb = Workbooks.Open(Repertoire & "\" & Fichier)
x = Workbooks(classeur1).Sheets(1).Range("A65536").End(xlUp).Row + 1

Set Ws = Wb.Sheets(1)
Ws.Range("A1:i2000").Copy _
Destination:=Workbooks(classeur1).Sheets(1).Range("a" & x)

Wb.Close False

Fichier = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Opération terminée."
End Sub

variante pour obtenir uniquement les valeurs


.....................................................
Do While Fichier <> ""
Set Wb = Workbooks.Open(Repertoire & "\" & Fichier)
x = Workbooks(classeur1).Sheets(1).Range("A65536").End(xlUp).Row + 1
Set Ws = Wb.Sheets(1)
Ws.Range("A1:i2000").Copy
Workbooks(classeur1).Sheets(1).Range("a" & x).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Wb.Close False
Fichier = Dir
Loop
...........................................

A tester et à modifier

JP