Regrouper pls classeur de plusieurs feuille dans le meme cla
bonsoir tout le monde,
Je souhaite regrouper plusieurs fichiers excel de plusieurs feuille sous un seul classeur, j'ai exécuté la macro suivante mais elle ne me prend que la première feuille des classeur et me les regroupe dans un seul classeur ou je la lance :
Option Explicit
Public Sub regroupe()
Dim chemin As String ' classeur regroupé
Dim rep As String ' répertoire à traiter
Dim fic As String ' classeur regroupé
Dim ligne As Long ' ligne écriture
Dim nbc As Integer ' nombre de classeurs
Dim Wf As Worksheet ' feuille regroupement
Dim Wl As Worksheet ' feuille regroupée
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
rep = ThisWorkbook.Path & "\"
On Error GoTo fin
Set Wf = ThisWorkbook.ActiveSheet ' variable feuille groupe
Wf.Cells.ClearContents
nbc = 0 ' initialisation variables
ligne = 1
fic = Dir(rep & "*.xls") ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
chemin = rep & fic ' chemin fichiers
Workbooks.Open chemin, 0 ' ouverture
Set Wl = ActiveWorkbook.Sheets(1)
Wl.Copy After:=Wf
Workbooks(fic).Close SaveChanges:=False ' Fermeture du classeur
nbc = nbc + 1
End If
fic = Dir
Wend
fin:
MsgBox nbc & " classeurs regroupés"
Application.DisplayAlerts = True
End Sub
je vous remercie par avance pour votre aide
Bonjour,
Pas testé, je t'en laisse le loisir :
Public Sub regroupe()
Dim Cls As Workbook
Dim Wl As Worksheet ' feuille regroupée
Dim chemin As String ' classeur regroupé
Dim rep As String ' répertoire à traiter
Dim fic As String ' classeur regroupé
Dim nbc As Integer ' nombre de classeurs
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
rep = ThisWorkbook.Path & "\"
On Error GoTo fin
nbc = 0 ' initialisation variables
fic = Dir(rep & "*.xls") ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
Set Cls = Workbooks.Open(rep & fic, 0) ' ouverture
With Cls
.Activate
For Each Wl In .Worksheets: Wl.Select False: Next
End With
With ThisWorkbook
ActiveWindow.SelectedSheets.Copy , .Sheets(.Sheets.Count)
End With
Cls.Close SaveChanges:=False ' Fermeture du classeur
nbc = nbc + 1
End If
fic = Dir
Wend
fin:
MsgBox nbc & " classeurs regroupés"
Application.DisplayAlerts = True
End Sub
MERCIIIIIIII ça marche au top