Création d'un nouveau classeur dans une procédure

Bonjour à toutes et tous,

Banzaii sur ce forum m'a aidé à améliorer le code ci après et qui donc fonctionne parfaitement.

Il fusionne plusieurs classeurs xlsb en un seul ((les feuilles de chacun des fichiers sources sont copiées dans autant de feuilles dans le fichier compilé final, les feuilles sont nommées avec le non du fichier original sans son extension plus un numéro de compteur dans le cas ou il y'aurait plusieurs feuilles ).

Je voudrais encore améliorer ce code en faisant en sorte que les feuilles soient copiées non pas sur le classeur (le nommé maitre dans le code) d'ou est lancée la macro mais sur un nouveau classeur vierge (j'ai essayé sans succès d'insérer l'instruction Wookbooks.Add).

Je sollicite donc votre aide.

Merci

Cordialement

Hugues

Sub Fusion()
Dim Maitre As Workbook
Dim Compteur As Integer
Dim Nf As String
Dim K As Integer

  Application.ScreenUpdating = False
  ChDir ActiveWorkbook.Path
  Set Maitre = ActiveWorkbook

  Nf = Dir("*.xlsb")
  Do While Nf <> ""
    If Nf <> Maitre.Name Then
      With Workbooks.Open(Filename:=Nf)
        For K = 1 To .Sheets.Count
          .Sheets(K).Copy after:=Maitre.Sheets(Maitre.Sheets.Count)
          ActiveSheet.Name = Replace(Nf, ".xlsb", "") & " " & K
        Next K
        .Close False
    End With
    End If
    Nf = Dir
  Loop
End Sub

Salut,

remplace juste la première ligne ci-dessous par la suivante :

Set Maitre = ActiveWorkbook

Set Maitre = Workbooks.Add

Bonjour lsa039,

Merci de ta réponse.

Mais malheureusement j'avais eu la même logique que toi mais la boucle ne fonctionne pas.

C'est a dire qu'il y arrêt à ce moment du code :

.Sheets(K).Copy after:=Maitre.Sheets(Maitre.Sheets.Count)

On se retrouve donc avec effectivement un nouveau classeur crée et actif, le premier classeur à compiler est bien ouvert aussi mais là arrêt de la procédure.

Je continue à chercher la bonne syntaxe et reste en attente de vos conseils à toutes et tous

Cordialement

Hugues

Essaye avec ceci :

Do While Nf <> ""

    If Nf <> Maitre.Name Then

        For k = 1 To ActiveWorkbook.Sheets.Count
            With Workbooks.Open(Filename:=Nf)
                .Sheets(k).Copy after:=Workbooks(Maitre).Sheets(Maitre.Sheets.Count)
                .Name = Replace(Nf, ".xlsb", "") & " " & k
                .Close False
            End With
        Next k

    End If
Nf = Dir

Loop

Re Bonjour Lsa039,

J'ai essayé ta solution et j'ai le message d'erreur suivant :

Erreur de compilation :

Impossible d'affecter à une priorité en lecture seule

Et cela concerne cette partie du code :

.Name = Replace(Nf, ".xlsb", "") & " " & K

Je vous ai remis la totalité du code tel que modifié en suivant les conseils de cette discussion.

Cordialement

Hugues

Sub Fusion2()
Dim Maitre As Workbook
Dim Compteur As Integer
Dim Nf As String
Dim K As Integer

  Application.ScreenUpdating = False
  ChDir ActiveWorkbook.Path
  Set Maitre = Workbooks.Add

  Nf = Dir("*.xlsb")

Do While Nf <> ""

    If Nf <> Maitre.Name Then

        For K = 1 To ActiveWorkbook.Sheets.Count
            With Workbooks.Open(Filename:=Nf)
                .Sheets(K).Copy after:=Workbooks(Maitre).Sheets(Maitre.Sheets.Count)
                .Name = Replace(Nf, ".xlsb", "") & " " & K
                .Close False
            End With
        Next K

    End If
Nf = Dir

Loop

End Sub

Bonjour à toutes et tous, Bonjour Lsa39, Bonjour Banzaii,

Merci à vous tous pour votre aide.

Grace à vos conseils et ceux d'autres internautes experts j'ai pu finaliser ma problématique.

Je marque donc ce poste comme résolu et laisse ici mon code final et fonctionnel par rapport à ce que j'en attend

Cordialement

Hugues

Sub Fusion2()
Dim Maitre As Workbook
Dim Second As Workbook
Dim Compteur As Integer
Dim Nf As String
Dim chemin As String
Dim K As Integer
Dim SaveFormat As Long

  Application.ScreenUpdating = False
  ChDir ActiveWorkbook.Path
  chemin = ActiveWorkbook.Path & "\"
  Set Maitre = ActiveWorkbook

  Application.DefaultSaveFormat = 50

  Workbooks.Add
  Set Second = ActiveWorkbook

  Nf = Dir("*.xlsb")
  Do While Nf <> ""
    If Nf <> Maitre.Name Then
      With Workbooks.Open(Filename:=Nf)
        For K = 1 To .Sheets.Count
          .Sheets(K).Copy after:=Second.Sheets(Second.Sheets.Count)
          ActiveSheet.Name = Replace(Nf, ".xlsb", "") & " " & K
        Next K
        .Close False
    End With
    End If
    Nf = Dir
  Loop

  Second.SaveAs (chemin & "nom_classeur" & ".xlsx")

Application.DefaultSaveFormat = SaveFormat

End Sub