Création d'onglets vba

Version imprimable

Bonjour à tous,

Je dispose d'un fichier présenté de cette façon :
Code_etu ; Nom_etu ; matière
6 ; dupont ; maths
6 ; dupont ; français
6 ; dupont ; anglais
7 ; dupontel ; maths
7 ; dupontel ; physique
....
et je souhaite créer autant de fichier qu'il y a d'étudiants et à l'intérieur de ces fichiers, autant d'onglet que de matières.
Par exemple, un fichier excel "6 dupont.xls" avec 3 onglets (maths, français et anglais).

La création de fichiers fonctionne, voici mon code :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Sub macro()
 
Dim rep As String, maquette As String, code_etu As String, nom_etu As String
Dim ligne As Integer, nbligne As Integer, nb_etu As Integer
 
donnees = "fichier test agri.xls"
nbligne = Workbooks(donnees).Worksheets("Feuil1").Range("A65536").End(xlUp).Row - 1
rep = "G:\documents\"
maquette = "maquette.xls"
 
Dim cellule As Range, celluledeux As Range, plage As Range
Dim adresse_cellule As String
Dim feuille_maquette As Worksheet
Set plage = Workbooks(donnees).Worksheets("Feuil1").Range("A2:A" & nbligne + 1)
Range("A2").Select
 
  For Each cellule In plage
    If cellule.Value <> "" Then
        If cellule.Value <> cellule.Offset(1, 0).Value Then
            code_etu = cellule.Value
            nom_etu = cellule.Offset(0, 1).Value
 
            'Sauvegarde du fichier etudiant
            Workbooks.Open Filename:=rep & maquette, UpdateLinks:=0
            Application.DisplayAlerts = False
            Workbooks(maquette).SaveAs Filename:=rep & "Livrables\" & code_etu & " " & nom_etu & ".xls", _
            FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
 
            'Création des feuilles
            Range("C2").Select
            adresse_cellule = cellule.Offset(0, 2).Address
            For Each celluledeux In Workbooks(donnees).Worksheets("Feuil1").Range("C2:" & adresse_cellule)
                Set feuille_maquette = ActiveWorkbook.Worksheets("Feuil1")
                feuille_maquette.Copy Before:=Sheets("Feuil2")
                ActiveSheet.Name = celluledeux.Value
            Next celluledeux
        End If
    End If
  Next cellule
 
End Sub

La création des fichiers excel marche mais pas celle des feuilles... Cela marche seulement pour le premier étudiant, pour le 2ème, vba me créé autant d'onglets qu'il y a de ligne dans mon fichier excel de base. (or je voudrais seulement les onglets maths et physique)
Je n'arrive pas à résoudre mon problème...

Merci d'avance pour votre aide!

12/02/2013, 15h52
COCONUT2

Vba est géré par un ordi qui est tres basique.

Lorsque tu travailles sur plusieurs classeurs, il faut lui dire sur quel objet il doit travailler sinon, il fait des conneries!

Quand il doit travailler avec ton classeur de base, utilise Thisworkbook:

Thisworkbook.sheets(1).range("A1:B45")

par exemple

Apres l'ouverture du classeur maquette et son enregistrement,
stocke son nom dans une variable par exemple NouvEtud

et utilise

Code:

Workbook(NouvEtud).sheets.add

Ce qui te permet de toujours savoir sur quel classeur tu travaille!
12/02/2013, 16h22
Oreo_

Merci coconut.
Mais je pense que le soucis vient de la deuxième boucle For...
12/02/2013, 20h59
Invité

Création d'onglets vba

Bonsoir,
Est-il possible de nous fournir dans un fichier Excel quelques lignes du fichier de base ?

Bonjour,
Je pense que cela peut se résumer à une petite procédure qui parcourt le fichier où se trouve la liste des données qui appele la procédure de création de classeur et la procédure de création de feuille.
On suppose dans cet exemple que la liste commence en A1
Au préalable il faut trier la liste de données pour avoir dans l'ordre : Code, Nom, Matière
Le code

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Option Explicit
Sub Test()
 Dim sht As Worksheet, rng As Range
 Dim Row As Long, wkName As String, shName As String
 Set sht = ThisWorkbook.Worksheets("Feuil1")
 Set rng = sht.Range("A1").CurrentRegion
 ' 
 ' Procédure Tri à placer ici 
 ' 
For Row = 2 To rng.Rows.Count
  If rng.Cells(Row, 2) <> wkName Then
   wkName = rng.Cells(Row, 2): CreaWorkBook wkName
  End If
  If rng.Cells(Row, 3) <> shName Then
   shName = rng.Cells(Row, 3): CreaWorkSheet shName
  End If
 Next
End Sub
Sub CreaWorkBook(Name As String)
 MsgBox "Creation classeur " & Name
End Sub
Sub CreaWorkSheet(Name As String)
 MsgBox "Creation feuille " & Name
End Sub

Donc à la place des msgbox, il faut placer les codes de création
A prévoir aussi une constante ou une variable contenant le chemin de répertoire où créer les classeurs

[EDIT]
On peut faire plus court en transformant les procédures Sub en Function

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub Test()
 Dim sht As Worksheet, rng As Range
 Dim Row As Long, wkName As String, shName As String
 Set sht = ThisWorkbook.Worksheets("Feuil1")
 Set rng = sht.Range("A1").CurrentRegion
 ' Procédure Tri
 For Row = 2 To rng.Rows.Count
  If rng.Cells(Row, 2) <> wkName Then wkName = CreaWorkBook(rng.Cells(Row, 2))
  If rng.Cells(Row, 3) <> shName Then shName = CreaWorkSheet(rng.Cells(Row, 3))
 Next
End Sub
Function CreaWorkBook(Name As String) As String
 MsgBox "Creation classeur " & Name
 CreaWorkBook = Name
End Function
Function CreaWorkSheet(Name As String) As String
 MsgBox "Creation feuille " & Name
 CreaWorkSheet = Name
End Function

13/02/2013, 10h53
Oreo_

Bonjour,

Merci beaucoup Phillipe, ton code fonctionne, le seul soucis est que le nom du classeur devrait se composer du code de l'étudiant et de son nom "6 dupont.xls".
Aussi, j'aurais préféré que l'on adapte mon code (car j'ai l'impression de n'avoir rien fait du coup et que mes recherches n'ont servi à rien.. :oops: mais je comprend que ce soit pas évident de modifier un code déjà fait).

Que signifie "CurrentRegion"?
13/02/2013, 10h56
Oreo_

1 pièce(s) jointe(s)

Citation:

Envoyé par rdurupt

Bonsoir,
Est-il possible de nous fournir dans un fichier Excel quelques lignes du fichier de base ?

Bonjour,

En pièce jointes un échantillon du fichier.

Merci d'avance

Bonjour,

Citation:

Envoyé par Oreo_

Bonjour,
Merci beaucoup Phillipe, ton code fonctionne, le seul soucis est que le nom du classeur devrait se composer du code de l'étudiant et de son nom "6 dupont.xls".
Aussi, j'aurais préféré que l'on adapte mon code (car j'ai l'impression de n'avoir rien fait du coup et que mes recherches n'ont servi à rien.. :oops:).

Dans la solution que je propose, les procédures sont décomposées ce qui est plus simple pour la maintenance.
Une procédure parcourt le fichier où se trouve les informations, une autre est prévue pour créer un classeur et une autre pour créer une feuille.
La procédure pour créer un classeur qui est ici une fonction reçoit un argument qui est le nom à donner au classeur.
Code:

1 2 3 4 Function CreaWorkBook(Name As String) As String MsgBox "Creation classeur " & Name CreaWorkBook = Name End Function
Le code qui invoque cette fonction envoie le nom du classeur à créer
Donc il y a lieu de concaténer les valeurs de la colonne 1 & 2
Voici le code qui créer le classeur et les feuilles (il reste à créer le code qui supprime la feuille nommée Feuil1 de chaque classeur mais je te laisse le soin de le faire.
Il faut juste changer la valeur de la constante Folder
Ne pas oublier que la liste doit être triée
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 Option Explicit Const Folder As String = "Z:\Tests\Creation\" Dim wkName As String, shName As String Sub Test() Dim sht As Worksheet, rng As Range, cName As String Dim Row As Long Set sht = ThisWorkbook.Worksheets("Feuil1") Set rng = sht.Range("A1").CurrentRegion ' Procédure Tri For Row = 2 To rng.Rows.Count With rng cName = .Cells(Row, 1) & .Cells(Row, 2) If cName <> wkName Then wkName = CreaWorkBook(cName) If rng.Cells(Row, 3) <> shName Then shName = CreaWorkSheet(rng.Cells(Row, 3)) End With Next End Sub Function CreaWorkBook(Name As String) As String 'MsgBox "Creation classeur " & Name Application.DisplayAlerts = False If Len(wkName) Then ActiveWorkbook.Close savechanges:=True Application.DisplayAlerts = True Workbooks.Add (1) ActiveWorkbook.SaveAs Filename:=Folder & Name ' & ".xls" CreaWorkBook = Name End Function Function CreaWorkSheet(Name As String) As String With ActiveWorkbook .Worksheets.Add Before:=Sheets(1) .Worksheets(1).Name = Name End With ' MsgBox "Creation feuille [" & Name & "]" & " (" & wkName & ")" CreaWorkSheet = Name End Function

Est-il possible de nous fournir dans un fichier Excel quelques lignes du fichier de base ?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Dim Etudiants As Collection
Dim Matieres As Collection
Const rep = "G:\documents\"
Const maquette = "maquette.xls"
 
 
Private Sub matiere(V As String)
On Error Resume Next
    Matieres.Add V, "Name_" & V
On Error GoTo 0
End Sub
Private Sub Etudiant(cd As String, etu As String)
On Error Resume Next
    Etudiants.Add cd & " " & etu, "Name_" & cd & "_" & etu
On Error GoTo 0
End Sub
Sub scan()
Dim Myrange As Range
Dim L As Long
Set Etudiants = New Collection
Set Matieres = New Collection
Set Myrange = ActiveSheet.Range("A1").CurrentRegion
For L = 2 To Myrange.Rows.Count
    Etudiant Trim("" & Myrange(L, 1)), Trim("" & Myrange(L, 2))
    matiere Trim("" & Myrange(L, 3))
Next
For L = 1 To Etudiants.Count
    CreerClasseur Etudiants(L)
Next
End Sub
 
Private Sub CreerClasseur(Name)
Dim MyClasseur As Workbooks
Set MyClasseur = ActiveWorkbook.Application.Workbooks.Add(rep & maquette)
CreerFeuille MyClasseur
MyClasseur.SaveAs rep & "Livrables\" & Name
MyClasseur.Close False
End Sub
Private Sub CreerFeuille(Classeur As Workbook)
Dim M As Long
Dim feuille_maquette As Worksheet
Dim FeuilleNew As Worksheet
For M= 1 To Matieres.Count
    Classeur.Sheets(1).Select
    Set FeuilleNew = Classeur.Sheets.Add
    Set feuille_maquette = Classeur.Worksheets("Feuil1")
    feuille_maquette.Copy Before:=FeuilleNew 
    FeuilleNew.Name = Matieres(M)
Next
 
End Sub

13/02/2013, 14h09
Oreo_

Merci à vous deux pour votre aide précieuse!