Macro permettant de c/c onglets issues de plusieurs classeurs dans un même

Bonjour,

Je me permets de solliciter votre aide...

Je souhaite copier l'onglet "ETUDE" de plusieurs classeurs (tous sauvegardés dans un même dossier) et les coller dans un nouveau classeur (de synthèse) les uns à la suite des autres dans différents onglets. Le classeur de destination aura autant d'onglets que de classeur à visiter.

J'aimerais renommer l'onglet ETUDE lorsque je copie l'onglet par le nom du classeur d'où vient l'onglet.

Bonjour

Dans un module standard

Sub CopieOnglets()
  Dim wbC As Workbook, wbS As Workbook
  Dim sh As Worksheet
  Dim chemin As String, fichier As String

  Set wbC = ThisWorkbook
  chemin = wbC.Path & "\Etudes\" ' Chemin vers le dossier des classeurs à traiter

  fichier = Dir(chemin)
  Do While fichier <> ""
    Set wbS = Workbooks.Open(chemin & fichier)
    For Each sh In wbS.Sheets
      If sh.Name = "Etude" Then
        sh.Copy after:=wbC.Sheets(Sheets.Count)
        ActiveSheet.Name = Left(fichier, Len(fichier) - 5)
        Exit For
      End If
    Next sh
    wbS.Close False
    fichier = Dir
  Loop

End Sub

sh.Copy after:=wbC.Sheets(Sheets.Count)

Tout d'abord merci beaucoup pour ton aide et retour.

Je viens d'essayer la macro qui est beaucoup plus propre et simple que celle que j'étais en train de construire ….en l'adaptant :

ub CopieOnglets()
  Dim wbC As Workbook, wbS As Workbook
  Dim sh As Worksheet
  Dim chemin As String, fichier As String

  Set wbC = ThisWorkbook
  chemin = wbC.Path & "\XLS\" ' Chemin vers le dossier des classeurs à traiter
  fichier = Dir(chemin & "*.xlsm") 'définit le premier fichier F avec extension .xlsm ayant CA comme chemin d'accès (extension à adapter)
  Do While fichier <> ""
    Set wbS = Workbooks.Open(chemin & fichier)
    For Each sh In wbS.Sheets
      If sh.Name = "ETUDE" Then
        sh.Copy after:=wbC.Sheets(Sheets.Count)
        ActiveSheet.Name = Left(fichier, Len(fichier) - 5)
        Exit For
      End If
    Next sh
    wbS.Close False
    fichier = Dir
  Loop

End Sub

Cependant j'ai un débogage sur :

sh.Copy after:=wbC.Sheets(Sheets.Count)

sur cette ligne

La fonction que j'avais commencé à adapter effectue des actions mais cependant pas celles voulues :

- Elle copie les onglets ETUDE de mes fichiers mais ne les enregistre pas dans le fichier Destination, elle crée pour chaque onglet un nouveau dossier

- Les onglets ne sont pas encore renommé

Sub Macrorecap()

Application.DisplayAlerts = False

Dim CD As Workbook 'déclare la variable CD (Classeur Destinsation)

Dim OD As Worksheet 'déclare la variable OD (Onglet Destinsation)

Dim CA As String 'déclare la variable CA (Chemin d'Accès)

Dim F As String 'déclare la variable F (Fichier)

Dim CS As Workbook 'définit la variable CS (Classeur Source)

Dim OS As Worksheet 'déclare la variable OS (Onglet Source)

Dim J As Long

Set CD = ThisWorkbook 'définit le classeur destination CD

'Set OD = CD.Worksheets("Feuil1") 'définit l'onglet Destination

CA = "XXX\XLS\" 'définit la chemin d'acces du dossier des fichiers source

F = Dir(CA & "*.xlsm") 'définit le premier fichier F avec extension .xlsm ayant CA comme chemin d'accès (extension à adapter)

Do While F <> ThisWorkbook.Name And F Like "*.xlsm"

For J = 1 To ThisWorkbook.Worksheets.Count

Application.Workbooks.Open (CA & F), UpdateLinks:=0 'ouvre le fichier F

Set CS = ActiveWorkbook 'définit le classeur CS

Set OS = CS.Worksheets("ETUDE") 'définit l'onglet OS

OS.Copy

ThisWorkbook.Sheets(J).Activate

Range("A1").Activate

Range("A1").Select

Range("A1").PasteSpecial xlPasteAll

CS.Close False 'ferme le classeur source sans enregistrer

Set CS = Nothing 'initialise la variable CS

F = Dir 'définit le prochain fichier F ayant avec extension .xlsx ayant CA comme chemin d'accès

Next J

Loop 'boucle

Application.DisplayAlerts = True

End Sub

Je pense avoir trouvé la solution. Merci beaucoup !!

Si ça marche c'est l'essentiel