Création des copies d'un classeur

[Adamev]

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

 

[kjin]

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) !

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

 

[Adamev]

Re : Création des copies d'un classeur

Bonsoir kjin
Merci bien pour ta réponse.
Effectivement les classes sont listées en A2:A21 (classes C1 à C20) ... Erreur de ma part, désolé.
Je vais tester le code..
A+

 

[Adamev]

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+

 

[kjin]

Re : Création des copies d'un classeur

Re,

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

 

[Adamev]

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+