Création des copies d'un classeur

  • Initiateur de la discussion Initiateur de la discussion Adamev
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Adamev

XLDnaute Occasionnel
Bonjour;
J'ai un classeur de type xlsm, nommé BDDEléves comportant 21 Feuilles nommées C1, C2, C3, …,C20. Chaque feuille est conçue pour une classe d'un établissement scolaire qui en comporte 20). La 21ème feuille est nommée Profs_Eléves, on y trouve l'attribution des classes aux professurs.
Je voudrais, à partir de ce classeur, créer 10 autres, de type xls, que je nommerais Prof1, Prof2, Prof3, …, Prof10, destinés, chacun à un professeur de l'établissement, de façon que le classeur Prof1, par exemple,
- ne contienne que les feuilles portant les noms des classes de ce professeur 1, et que les autres feuilles soient supprimées;
- porte le nom de ce professeur 1;
- soit enregistré dans le même dossier où se trouve le classeur BDDEléves;
Ceci étant; je voudrais que le classeur BDDEléves reste inchangé.
Merci d'avance de m'aider
 

Pièces jointes

Re : Création des copies d'un classeur

Bonjour,
Je suppose que ton tableau est erroné et que les classes sont listées en A2:A21 (classes C1 à C20) !
Code:
Sub CreerProfs()
Dim wbSource As Workbook, wbProf As Workbook
Dim Prof$, classe$
Dim i%, j%
Set wbSource = ThisWorkbook
tablo = Sheets("Profs_Elèves").Range("A1:K21").Value
For i = 2 To UBound(tablo, 2)
    Prof = tablo(1, i)
    Set wbProf = Workbooks.Add
    For j = UBound(tablo, 1) To 2 Step -1
        If UCase(tablo(j, i)) = "X" Then
            classe = tablo(j, 1)
            wbSource.Sheets(classe).Copy Before:=wbProf.Sheets(1)
        End If
    Next
    Application.DisplayAlerts = False 'attention : écrase le fichier existant !!
    wbProf.SaveAs ThisWorkbook.Path & "\" & Prof & ".xlsx" 'adapter si besoin
    wbProf.Close
Next
End Sub
A+
kjin
 
Dernière édition:
Re : Création des copies d'un classeur

Re;
kjin, ton code répond à mes souhaits parfaitement.
Je te remercie beaucoup.
Mais Il y a un tout petit souci: les classeurs créés comportent, en plus des feuilles requises, trois feuilles: Feuil1, Feuil2, Feuil3.
Merci de me consacrer encore quelques minutes de ton temps.
A+
 
Re : Création des copies d'un classeur

Re,
Code:
Sub CreerProfs()
Dim wbSource As Workbook, wbProf As Workbook
Dim Prof$, classe$
Dim i%, j%
Set wbSource = ThisWorkbook
tablo = Sheets("Profs_Elèves").Range("A1:K21").Value
For i = 2 To UBound(tablo, 2)
    Prof = tablo(1, i)
    Set wbProf = Workbooks.Add
    For j = UBound(tablo, 1) To 2 Step -1
        If UCase(tablo(j, i)) = "X" Then
            classe = tablo(j, 1)
            wbSource.Sheets(classe).Copy Before:=wbProf.Sheets(1)
        End If
    Next
    Application.DisplayAlerts = False 'attention : écrase le fichier existant !!
    With wbProf
        For Each sh In .Sheets 'suppression des feuilles nommées Feuil1, Feuil1, ...
            If sh.Name Like "Feuil*" Then sh.Delete
        Next
        .SaveAs ThisWorkbook.Path & "\" & Prof & ".xlsx" 'adapter si besoin
        .Close
    End With
Next
End Sub
A+
kjin
 
Re : Création des copies d'un classeur

Bonsoir kjin;
Un grand merci, c'est parfait, et élégant et surtout c'est ultra rapide.
Une petite question pour terminer:
N'est -il pas nécessaire d'ajouter

Application.DisplayAlerts = True
avant
"End Sub"
ou bien c'est Excel qui s'en occupe?
A+
 
Dernière édition:
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
4
Affichages
2 K
Compte Supprimé 979
C
Retour