Macro création d'onglets..

Version imprimable

02/03/2011, 17h12
roberto75

Macro création d'onglets..

Salut à toi,

J'aurai besoin de tes lumières pour créer une macro excel. Au commencement, j'ai un fichier excel de type .xls qui contient des données de plusieurs patients. Toutes les données sont contenues dans une seule et unique colonne ; la colonne A. Seul le nombre de ligne varie dans cette colonne A. Toute les 10 lignes on change de patient, des lignes A1 à A10 on a les données du patient 1, des lignes A11 à A20 on a les données du patient 2 ect.... Et la première cellule de chaque patient (A1,A11 ect....) contient le nom du patient.

On a un truc de ce genre dans notre fichier xls.

Pierre <-- A1
1
2
3
4
5
6
7
8
9
Paul <-- A11
12
54
24
58
24
26
25
8
55
Jack <-- A21
20
20
20
20
20
20
20
20
20
[case vide]

Ce que j'aimerai que ma macro fasse, c'est qu'elle crée un fichier excel normal, dans lequel elle importera toutes les valeurs des patients du fichier xls. de telle sorte qu'on ait dans ce nouveau fichier pour chaque patient, un onglet qui porte le nom du patient et qui contient ses données. On aurait donc ici 3 onglets, Pierre Paul et Jack qui contiennent leurs données respectives. Voilà !

Pouvez-vous me dire comment procéder ? Merci

A bientôt

Bonsoir,

Les valeurs de ta feuilles doivent toutes être comme dans ton exemple, teste :

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
 
Sub ClasseurPatients()
 
    Dim Cls As Workbook
    Dim Fe As Worksheet
    Dim FeAjout As Worksheet
    Dim Plage As Range
    Dim I As Integer
    Dim Tbl
 
    'adapter le nom de la feuille où se trouvent les valeurs
    Set Fe = ThisWorkbook.Worksheets("Feuil1")
 
    'crée le classeur
    Set Cls = Workbooks.Add
 
    'défini la plage pour la récupération des valeurs
    With Fe
        Set Plage = .Range(.[A1], .[A65536].End(xlUp))
    End With
 
    'passe la plage de 10 en 10
    For I = 1 To Plage.Count Step 10
 
        'ajoute une feuille au classeur
        Set FeAjout = Cls.Worksheets.Add
 
        'renomme la feuille au nom du patient
        FeAjout.Name = Plage(I)
 
        'utilise un tableau intermédiaire pour récupérer
        'les valeurs de chaque patient
        Tbl = Fe.Range(Plage(I + 1), Plage(I + 9))
 
        'puis les colle de A1 à A10
        FeAjout.[A1:A9] = Tbl
 
    Next I
 
End Sub

Hervé.

03/03/2011, 11h01
roberto75

Bonjour Hervé,

Merci pour ce code commenté, j'ai tout compris et ça marche du feu de Dieu.

J'aurai voulu savoir s'il était possible de créer les onglets dans un ordre précis c'est à dire l'onglet Pierre (A1) en première position en partant de la gauche ensuite l'onglet Paul(A11) ect.... /Pierre/Paul/Jack/ect...

Lorsqu'on créer le classeur 'Cls', est-ce qu'on peut supprimer automatiquement les feuilles vides (feuil1, feuil2, feuil3) qui sont toujours présentes lors de la génération dudit classeur.

Et dernière chose, peut-on donner un nom particulier au classeur "Cls" géneré, par exemple 'nomconstant DATEDUJOUR'

Merci pour ton aide,

@+
03/03/2011, 11h18
mercatog
1.

Code:

Set Cls = Workbooks.Add(1)

Nouveau classeur avec une seule feuille (attention, le 1 ne signifie pas le nombre de feuilles) Fais un F1 sur la méthode Add
2.

Code:

Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Cls.Worksheets.Count)

La nouvelle feuille crée est placée en dernier
3.

Code:

Set FeAjout = Cls.Worksheets(1).Delete

Permet de supprimer la Feuille 1 (la seule feuille vide qui a été créée avec la création du classeur Cls)
4.
Code:

1 2 Chemin="C:\Documents and Settings\Administrateur\Bureau\"'Ici mettre le chemin de ton dossier où enregistrer Cls.SaveAs Chemin & "Toto " & Format(Date, "ddmmyyyy") &".xls"
Permet d'enregistrer Cls dans Chemin sous le nom Toto03032011.xls (exemple pour aujourd'hui)

Bonjour et Merci Mercatog,

**Donc j'ai essayé de compléter le code avec tes contributions mais j'obtiens une petite erreur ligne 27 au niveau du Delete, on me dit que "les feuilles sélectionnées peuvent contenir des données. Pour supprimer définitivement les données, cliquez sur supprimer" Donc si je clique sur supprimer ou annuler et il me dit "Erreur d'exécution "429". Objet requis"

**Dans ma feuille initiale Fe, les données de chaque patient sont séparées par une case vide, est-il possible de supprimer ces cases vides au début de la macro ?
Pierre --> A1
1
2
3
4
5
6
7
8
9
[case vide] --> à supprimer
Paul --> A11
22
22
11
11
55
44
77
88
99
[case vide] --> à supprimer
ect...
Fin
[case vide]
[case vide]
[case vide]

**Concernant le chemin d'enregistrement du fichier Cls.xlsx, peut-on definir un chemin qui enregistre le fichier toujours sur le Bureau quelque soit le nom du disque dur 'Chemin= codegénérique "\Bureau\"' (on est sous windows)

**Dernière question, lorsque la macro génère les différents onglets, elle sélectionne systématiquement le dernier onglet crée. Peut-on faire en sorte qu'elle active toujours le premier onglet crée, l'onglet Pierre dans notre exemple.

Encore merci à vous,

A plus tard !
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 Sub ClasseurPatients() Dim Cls As Workbook Dim Fe As Worksheet Dim FeAjout As Worksheet Dim Plage As Range Dim I As Integer Dim Tbl 'adapter le nom de la feuille où se trouvent les valeurs Set Fe = ThisWorkbook.Worksheets("Feuil1") 'crée le classeur avec une seule feuille Set Cls = Workbooks.Add(1) 'défini la plage pour la récupération des valeurs With Fe Set Plage = .Range(.[A1], .[A65536].End(xlUp)) End With 'passe la plage de 10 en 10 For I = 1 To Plage.Count Step 10 'ajoute une feuille au classeur en dernière position Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Cls.Worksheets Count) 'On supprime la Feuil1 Set FeAjout = Cls.Worksheets(1).Delete 'renomme la feuille au nom du patient FeAjout.Name = Plage(I) 'utilise un tableau intermédiaire pour récupérer 'les valeurs de chaque patient Tbl = Fe.Range(Plage(I + 1), Plage(I + 9)) 'puis les colle de A1 à A10 FeAjout.[A1:A9] = Tbl Next I 'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA Chemin="C:\Users\87\Desktop\" Cls.SaveAs Chemin & "Toto" & Format(Date, "ddmmyyyy") &".xlsx" End Sub

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
Sub ClasseurPatients()
Dim Cls As Workbook
Dim Fe As Worksheet, FeAjout As Worksheet
Dim Plage As Range
Dim i As Integer
Dim Chemin As String
 
Application.ScreenUpdating = False
'adapter le nom de la feuille où se trouvent les valeurs
Set Fe = ThisWorkbook.Worksheets("Feuil1")
'crée le classeur avec une seule feuille
Set Cls = Workbooks.Add(1)
'défini la plage pour la récupération des valeurs
With Fe
    Set Plage = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
'passe la plage de 10 en 10
For i = 1 To Plage.Count Step 11
    'ajoute une feuille au classeur en dernière position
    Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(1))
    'renomme la feuille au nom du patient
    FeAjout.Name = Plage(i)
    'puis les colle de A1 à A10
    FeAjout.Range("A1:A9").Value = Fe.Range(Plage(i + 1), Plage(i + 9)).Value
Next i
Set Fe = Nothing
Set Plage = Nothing
Set FeAjout = Nothing
'Supprime la feuille vide
Application.DisplayAlerts = False
Cls.Worksheets(1).Delete
Cls.Worksheets(1).Activate
'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA
Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Cls.SaveAs Chemin & "Toto" & Format(Date, "ddmmyyyy") & ".xlsx"
Application.DisplayAlerts = True
Cls.Close
Set Cls = Nothing
End Sub

Attention quand même si tu as 2 patients qui ont le même nom ou si le fichier Toto03032011.xlsx est ouvert.

03/03/2011, 15h57
roberto75

ça marche parfaitement, effectivement on s'arrange toujours pour avoir des patients avec une ID (nom) unique, donc à priori on ne devrait pas rencontrer ce problème.

Juste une dernière chose, lorsque la macro génère les onglets, le dernier onglet crée ici (Jack) se situe en première position en partant de la gauche. En fait, je voudrais savoir si on pouvait faire l'inverse, c'est à dire, avoir le premier onglet crée tout à gauche en première position et le dernier onglet tout à droite en dernière position. On aurait donc aurait 3 onglets dans cet ordre --> Pierre/Paul/Jack. "A1/A11/A21".

Et ça serait bien si on pouvait activer systématiquement le premier onglet créer (Pierre / A1) lorsqu'on ouvre notre feuille Cls.

Voilà, on y est presque :)

A bientôt.
03/03/2011, 16h13
Theze
Bonjour,

Pour mettre toujours la feuille créée avant les autres :
Code:

1 2 Set FeAjout = Cls.Worksheets.Add(Before:=Cls.Worksheets(1))
Pour l'activation de la 1ère feuille à l'ouverture, à mettre dans le module du classeur (ThisWorkbook) :
Code:

1 2 3 4 5 6 Private Sub Workbook_Open() Worksheets(1).Activate End Sub
Hervé.
03/03/2011, 17h16
roberto75
Citation:
Envoyé par Theze

Bonjour,

Pour mettre toujours la feuille créée avant les autres :

Code:

1 2 Set FeAjout = Cls.Worksheets.Add(Before:=Cls.Worksheets(1))

Hervé.
Pour l'activation de la 1ère feuille à l'ouverture ça marche parfaitement par contre j'ai un petit soucis concernant l'autre code. Lorsque je remplace After par Before j'obtiens un fichier Cls avec 3 onglets dans cet ordre Paul/Pierre/Feuil1 l'onglet Jack a disparu.

J'ai donc remplacé le 1 par Worksheets.Count et ça marche plutôt bien, par contre je ne sais pas si le code est propre.

Code:

Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count))
04/03/2011, 13h37
mercatog

Bonjour
Analysons la situation
Tu crée un nouveau classeur avec une seule feuille (Feuil1 ou Sheet1 ou autre, ça dépends de la langue d'Excel)
Tu parcours la colonne A de ton fichier d'origine à partir de la ligne 1 et avec un décalage de 11 cellules (A1:A12:A23....)

1. Quand tu fais

Code:

Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(1))

1.a. La première feuille correspondant au patient A1 s'ajoute en position 2
1.b. La deuxième feuille correspondant au patient A12 s'ajoute en position 2, donc la feuille de patient A1 devient en position 3
...etc

2. Quand tu fais

Code:

Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count))

2.a. Au départ Worksheets.Count=1 (1 seule feuille dans le classeur Cls), donc la première feuille correspondant au patient A1 s'ajoute en position 2
2.b. Worksheets.Count=2 (2 feuilles dans le classeur Cls), la deuxième feuille correspondant au patient A12 s'ajoute en position 3 et la feuille de patient A1 reste en position 2
...etc

3. Maintenant si tu fais

Code:

Set FeAjout = Cls.Worksheets.Add(Before:=Cls.Worksheets(1))

3.a. La première feuille correspondant au patient A1 s'ajoute en position 1 et la feuille vide initiale de Cls devient en position 2
3.b. La deuxième feuille correspondant au patient A12 s'ajoute en position 1, donc la feuille de patient A1 devient en position 2 et la feuille vide initiale de Cls devient en position 3
...etc
En fin de compte pour supprimer la feuille vide initiale Feuil1, tu devrai faire

Code:

Cls.Worksheets(Cls.Worksheets(Worksheets.Count)).Delete

En conclusion:
Dans les cas 1 et 3 qui sont identiques, tu auras la feuille du patient A1 en dernier, la feuille du patient A12 est l'avant dernière...
Dans le cas 2 tu auras la feuille du patient A1 en première position, la feuille du patient A12 est en deuxième position...

Bonjour,

Très bien, donc c'est bien le cas 2 qui m'intéresse et ça marche parfaitement, merci. Je suis en train d'adapter la macro à mon fichier de données et j'ai un petit soucis. En fait les noms des patients se situent dans les cellules B2,B13,B24 ect.... et les données dans les colonnes adjacentes de la cellule du nom du patient. Par exemple pour le patient Pierre, le nom du patient se situe en B2 et ses données de A3 à A11 et de C3 à C11, j'aimerai avoir pour chaque patient un onglet portant son nom et contenant ses données A3 à A11 collées en A1 à A9 et C3 à C11 collées en C1 à C9. Je ne vois pas trop comment m'y prendre, merci pour votre aide . A plus tard

http://img4.hostingpics.net/pics/281752aa.png
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 52 53 54 55 Sub ClasseurPatients() Dim Cls As Workbook Dim Fe As Worksheet, FeAjout As Worksheet Dim Plage As Range Dim i As Integer Dim Chemin As String Application.ScreenUpdating = False 'adapter le nom de la feuille où se trouvent les valeurs Set Fe = ThisWorkbook.Worksheets("Feuil1") 'crée le classeur avec une seule feuille Set Cls = Workbooks.Add(1) 'défini la plage pour la récupération des valeurs With Fe Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) End With 'passe la plage de 10 en 10 For i = 1 To Plage.Count Step 11 'ajoute une feuille au classeur en dernière position Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count)) 'renomme la feuille au nom du patient FeAjout.Name = Plage(i) 'puis les colle de A1 à A10 FeAjout.Range("A1:A9").Value = Fe.Range(Plage(i + 1), Plage(i + 9)).Value Next i Set Fe = Nothing Set Plage = Nothing Set FeAjout = Nothing 'Supprime la feuille vide Application.DisplayAlerts = False Cls.Worksheets(1).Delete Cls.Worksheets(1).Activate 'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" Cls.SaveAs Chemin & "Toto" & Format(Date, "ddmmyyyy") & ".xlsx" Application.DisplayAlerts = True Cls.Close Set Cls = Nothing End Sub

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
Dim Cls As Workbook
Dim Fe As Worksheet, FeAjout As Worksheet
Dim LastLig As Integer, i As Integer
Dim Chemin As String
 
 
Application.ScreenUpdating = False
'adapter le nom de la feuille où se trouvent les valeurs
Set Fe = ThisWorkbook.Worksheets("Feuil1")
'crée le classeur avec une seule feuille
Set Cls = Workbooks.Add(1)
'défini la plage pour la récupération des valeurs
With Fe
    'Dernière ligne remplie de la colonne "B" (patients)
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
    'passe la plage de 10 en 10
    For i = 2 To LastLig Step 11
        'ajoute une feuille au classeur en dernière position
        Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count))
        'renomme la feuille au nom du patient
        FeAjout.Name = .Range("B" & i).Value
        'puis les colle de A1 à A10
        FeAjout.Range("A1:A9").Value = .Range("A" & i + 1 & ":A" & i + 9).Value
        FeAjout.Range("C1:C9").Value = .Range("C" & i + 1 & ":C" & i + 9).Value
    Next i
End With
Set Fe = Nothing
Set FeAjout = Nothing
'Supprime la feuille vide
Application.DisplayAlerts = False
Cls.Worksheets(1).Delete
Cls.Worksheets(1).Activate
'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA
Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Cls.SaveAs Chemin & "Toto" & Format(Date, "ddmmyyyy") & ".xlsx"
Application.DisplayAlerts = True
Cls.Close
Set Cls = Nothing

Bonsoir,
ça marche à merveille :ccool: , j'ai légèrement modifié le code pour obtenir exactement ce que je voulais, vraiment merci.

Dans un second temps, afin de pouvoir faire des statistiques, j'ai besoin que la macro créée un nouveau fichier excel contenant uniquement 3 onglets nommées A, B et C.

Pour les 3 onglets on aurait les noms de tous les patients les uns à la suite des autres (onglets du fichier Cls) dans la colonne A, en commençant par Pierre (le premier onglet créer dans le fichier Cls) et dans les colonnes B,C,D on aurait certaines données de chaque patient, qui sont présentent dans le fichier Cls généré précédemment. Mais, je ne sais pas comment procéder.

1- La macro précédente a crée un fichier Cls avec des onglets (ici Pierre et Paul) ayant tous la même structure, toutes les valeurs de la colonne A et des cellules B2,C3 sont des constantes ;

http://img4.hostingpics.net/pics/970626Pierre.png

http://img4.hostingpics.net/pics/456187Paul.png

2- On génère ensuite un fichier excel avec 3 onglets A, B et C avec une disposition des données et des noms de chaque patient de cette façon.

http://img4.hostingpics.net/pics/518314ongA.pnghttp://img4.hostingpics.net/pics/683584ongB.pnghttp://img4.hostingpics.net/pics/785321ongC.png

Encore merci pour votre aide, A bientôt.
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 52 53 54 55 56 57 58 59 60 Sub ClasseurPatients() Dim Cls As Workbook Dim Fe As Worksheet, FeAjout As Worksheet Dim LastLig As Integer, i As Integer Dim Chemin As String Application.ScreenUpdating = False 'adapter le nom de la feuille où se trouvent les valeurs Set Fe = ThisWorkbook.Worksheets("Feuil1") 'crée le classeur avec une seule feuille Set Cls = Workbooks.Add(1) 'défini la plage pour la récupération des valeurs With Fe 'Dernière ligne remplie de la colonne "B" (patients) LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row 'passe la plage de 120 en 120 ( + cellule A1 vide) For i = 2 To LastLig Step 120 'ajoute une feuille au classeur en dernière position Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count)) 'renomme la feuille au nom du patient FeAjout.Name = .Range("B" & i).Value 'puis les colle de A1 à A119 (Pas de cellule vide en A1) FeAjout.Range("A1:A119").Value = .Range("A" & i & ":A" & i + 119).Value FeAjout.Range("B1:B119").Value = .Range("B" & i & ":B" & i + 119).Value FeAjout.Range("C1:C119").Value = .Range("C" & i & ":C" & i + 119).Value Next i End With Set Fe = Nothing Set FeAjout = Nothing 'Ajustement automatiquement de la largeur des colonnes For Each sh In ActiveWorkbook.Sheets sh.Cells.EntireColumn.AutoFit Next 'Supprime la feuille vide Application.DisplayAlerts = False Cls.Worksheets(1).Delete Cls.Worksheets(1).Activate 'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" Cls.SaveAs Chemin & "Toto" & Format(Date, "ddmmyyyy") & ".xlsx" Application.DisplayAlerts = True Cls.Close Set Cls = Nothing End Sub

Tu aurais mettre ceci

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
Sub ClasseurPatients()
Dim Cls As Workbook
Dim Fe As Worksheet, FeAjout As Worksheet
Dim LastLig As Integer, i As Integer
Dim Chemin As String
 
Application.ScreenUpdating = False
'adapter le nom de la feuille où se trouvent les valeurs
Set Fe = ThisWorkbook.Worksheets("Feuil1")
'crée le classeur avec une seule feuille
Set Cls = Workbooks.Add(1)
'défini la plage pour la récupération des valeurs
With Fe
    'Dernière ligne remplie de la colonne "B" (patients)
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
    'passe la plage de 120 en 120 ( + cellule A1 vide)
    For i = 2 To LastLig Step 120
        'ajoute une feuille au classeur en dernière position
        Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count))
        'renomme la feuille au nom du patient
        FeAjout.Name = .Range("B" & i).Value
        'puis les colle de A1 à C119 (Pas de cellule vide en A1)
        FeAjout.Range("A1:C119").Value = .Range("A" & i & ":C" & i + 119).Value
        'Ajustement automatiquement de la largeur des colonnes
        FeAjout.Columns("A:C").AutoFit
    Next i
End With
Set Fe = Nothing
Set FeAjout = Nothing
'Supprime la feuille vide
Application.DisplayAlerts = False
Cls.Worksheets(1).Delete
Cls.Worksheets(1).Activate
Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA
Cls.SaveAs Chemin & "Toto" & Format(Date, "ddmmyyyy") & ".xlsx"
Application.DisplayAlerts = True
Cls.Close
Set Cls = Nothing
End Sub

06/03/2011, 13h28
roberto75

Bonjour mercatog,

Merci d'avoir corrigé le code, aurais-tu aussi une idée de la manière dont je dois procéder pour créer un nouveau fichier excel avec ses 3 onglets A,B,C ect... (Cf. post précédent)

Merci, bonne fin de week end.

Dans le même ordre d'idé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
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
Sub ClasseurPatients()
Dim Cls As Workbook, Recap As Workbook
Dim Fe As Worksheet, FeAjout As Worksheet
Dim LastLig As Long, i As Long, j As Long
Dim Chemin As String
 
Application.ScreenUpdating = False
'adapter le nom de la feuille où se trouvent les valeurs
Set Fe = ThisWorkbook.Worksheets("Feuil1")
'crée le classeur récap avec 3 feuilles
Application.SheetsInNewWorkbook = 3
Set Recap = Workbooks.Add
'appel sub préparation classeur récap
PrepRecap Recap
'crée le classeur avec une seule feuille
Set Cls = Workbooks.Add(1)
j = 2
'défini la plage pour la récupération des valeurs
With Fe
    'Dernière ligne remplie de la colonne "B" (patients)
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
    'passe la plage de 120 en 120 ( + cellule A1 vide)
    For i = 2 To LastLig Step 120
        'ajoute une feuille au classeur en dernière position
        Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count))
        'renomme la feuille au nom du patient
        FeAjout.Name = .Range("B" & i).Value
        'puis les colle de A1 à C119 (Pas de cellule vide en A1)
        FeAjout.Range("A1:C119").Value = .Range("A" & i & ":C" & i + 119).Value
        'Ajustement automatiquement de la largeur des colonnes
        FeAjout.Columns("A:C").AutoFit
        'appel de la sub transfert données
        Transf .Range("B" & i).Value, Recap, FeAjout, j
        j = j + 1
    Next i
End With
Set Fe = Nothing
Set FeAjout = Nothing
'Supprime la feuille vide
Application.DisplayAlerts = False
Cls.Worksheets(1).Delete
Cls.Worksheets(1).Activate
Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA
Cls.SaveAs Chemin & "Toto" & Format(Date, "ddmmyyyy") & ".xlsx"
Cls.Close
Set Cls = Nothing
Recap.SaveAs Chemin & "Recap" & Format(Date, "ddmmyyyy") & ".xlsx"
Recap.Close
Set Recap = Nothing
Application.DisplayAlerts = True
End Sub
 
'Sub de préparation du classeur Récap
Sub PrepRecap(Wbk As Workbook)
 
With Wbk
    With .Sheets(1)
        .Name = "A"
        .Range("B1").Value = "CA"
        .Range("D1").Value = "EA"
    End With
    With .Sheets(2)
        .Name = "B"
        .Range("B1").Value = "HB"
    End With
    With .Sheets(3)
        .Name = "C"
        .Range("B1").Value = "MC"
        .Range("C1").Value = "NC"
    End With
End With
End Sub
 
'Sub de transfert des données vers le classeur récap
Sub Transf(ByVal Patient As String, Wbk As Workbook, Sh As Worksheet, ByVal Lig As Long)
 
With Wbk
    With .Sheets(1)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C6").Value
        .Range("D" & Lig).Value = Sh.Range("C8").Value
    End With
    With .Sheets(2)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C12").Value
    End With
    With .Sheets(3)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C18").Value
        .Range("C" & Lig).Value = Sh.Range("C19").Value
    End With
End With
End Sub

Bonsoir,

C'est vraiment super, ça marche pile-poil. Juste une dernière chose, ça concerne cette partie du code ;

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'Sub de préparation du classeur Récap
Sub PrepRecap(Wbk As Workbook)
 
With Wbk
    With .Sheets(1)
        .Name = "A"
        .Range("B1").Value = "CA"
        .Range("D1").Value = "EA"
    End With
    With .Sheets(2)
        .Name = "B"
        .Range("B1").Value = "HB"
    End With
    With .Sheets(3)
        .Name = "C"
        .Range("B1").Value = "MC"
        .Range("C1").Value = "NC"
    End With
End With
End Sub

Si par exemple, je voulais récupérer automatiquement la constante CA du classeur Cls, comment je devrais faire ? Merci beaucoup.

A plus

Aller chercher ces intitulés de ta feuille Fe
Cette opéaration est faite une seule fois lors de la création de ton classeur Recap
A toi d'adapter les bonne cellule dans la sub PrepRecap

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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
Sub ClasseurPatients()
Dim Cls As Workbook, Recap As Workbook
Dim Fe As Worksheet, FeAjout As Worksheet
Dim LastLig As Long, i As Long, j As Long
Dim Chemin As String
 
Application.ScreenUpdating = False
'adapter le nom de la feuille où se trouvent les valeurs
Set Fe = ThisWorkbook.Worksheets("Feuil1")
'crée le classeur récap avec 3 feuilles
Application.SheetsInNewWorkbook = 3
Set Recap = Workbooks.Add
'appel sub préparation classeur récap
PrepRecap Recap, Fe
'crée le classeur avec une seule feuille
Set Cls = Workbooks.Add(1)
j = 2
'défini la plage pour la récupération des valeurs
With Fe
    'Dernière ligne remplie de la colonne "B" (patients)
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
    'passe la plage de 120 en 120 ( + cellule A1 vide)
    For i = 2 To LastLig Step 120
        'ajoute une feuille au classeur en dernière position
        Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count))
        'renomme la feuille au nom du patient
        FeAjout.Name = .Range("B" & i).Value
        'puis les colle de A1 à C119 (Pas de cellule vide en A1)
        FeAjout.Range("A1:C119").Value = .Range("A" & i & ":C" & i + 119).Value
        'Ajustement automatiquement de la largeur des colonnes
        FeAjout.Columns("A:C").AutoFit
        'appel de la sub transfert données
        Transf .Range("B" & i).Value, Recap, FeAjout, j
        j = j + 1
    Next i
End With
Set Fe = Nothing
Set FeAjout = Nothing
'Supprime la feuille vide
Application.DisplayAlerts = False
Cls.Worksheets(1).Delete
Cls.Worksheets(1).Activate
Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA
Cls.SaveAs Chemin & "Toto" & Format(Date, "ddmmyyyy") & ".xlsx"
Cls.Close
Set Cls = Nothing
Recap.SaveAs Chemin & "Recap" & Format(Date, "ddmmyyyy") & ".xlsx"
Recap.Close
Set Recap = Nothing
Application.DisplayAlerts = True
End Sub
 
'Sub de préparation du classeur Récap
Sub PrepRecap(Wbk As Workbook, Sh As Worksheet)
 
With Wbk
    With .Sheets(1)
        .Name = "A"
        .Range("B1").Value = Sh.Range("A8")
        .Range("D1").Value = Sh.Range("A10")
    End With
    With .Sheets(2)
        .Name = "B"
        .Range("B1").Value = Sh.Range("A14")
    End With
    With .Sheets(3)
        .Name = "C"
        .Range("B1").Value = Sh.Range("A20")
        .Range("C1").Value = Sh.Range("A21")
    End With
End With
End Sub
 
'Sub de transfert des données vers le classeur récap
Sub Transf(ByVal Patient As String, Wbk As Workbook, Sh As Worksheet, ByVal Lig As Long)
 
With Wbk
    With .Sheets(1)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C6").Value
        .Range("D" & Lig).Value = Sh.Range("C8").Value
    End With
    With .Sheets(2)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C12").Value
    End With
    With .Sheets(3)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C18").Value
        .Range("C" & Lig).Value = Sh.Range("C19").Value
    End With
End With
End Sub

Bonsoir,

J'ai adapté la macro et ça marche plutôt bien. Merci :ccool:

1/ Histoire de fignoler les choses, je voulais faire un ajustement automatique de la largeur des colonnes du Classeur Recap, par contre je ne sais pas si ce que j'ai fait est très propre mais ça à l'air de marcher.

2/ J'ai également essayé de définir un zoom de 80% aux feuilles A,B,C de Recap, mais sans grand succès.

3/ Une dernière chose, est-il possible de générer les classeurs Toto et Recap dans un dossier de type NomDDMMAAAA, qui serait présent sur le bureau (dossier aussi généré par la macro)

Merci et à bientôt.

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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
Sub ClasseurPatients()
Dim Cls As Workbook, Recap As Workbook
Dim Fe As Worksheet, FeAjout As Worksheet
Dim LastLig As Long, i As Long, j As Long
Dim Chemin As String
 
Application.ScreenUpdating = False
 
'adapter le nom de la feuille où se trouvent les valeurs
Set Fe = ThisWorkbook.Worksheets("Feuil1")
 
'crée le classeur récap avec 3 feuilles
Application.SheetsInNewWorkbook = 3
Set Recap = Workbooks.Add
 
'appel sub préparation classeur récap
PrepRecap Recap, Fe
 
'crée le classeur avec une seule feuille
Set Cls = Workbooks.Add(1)
j = 2
 
'défini la plage pour la récupération des valeurs
With Fe
    'Dernière ligne remplie de la colonne "B" (patients)
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
 
    'passe la plage de 119 en 119 (cellule A1 vide)
    For i = 2 To LastLig Step 120
 
        'ajoute une feuille au classeur en dernière position
        Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count))
        'renomme la feuille au nom du patient
        FeAjout.Name = .Range("B" & i).Value
 
        'puis les colle de A2 à C120 (cellule A1 vide)
        FeAjout.Range("A2:C120").Value = .Range("A" & i & ":C" & i + 120).Value
 
        'Ajustement automatiquement de la largeur des 3 première colonnes
        FeAjout.Columns("A:C").AutoFit
 
        'appel de la sub transfert données
        Transf .Range("B" & i).Value, Recap, FeAjout, j
        j = j + 1
    Next i
End With
Set Fe = Nothing
Set FeAjout = Nothing
 
'Supprime la feuille vide
Application.DisplayAlerts = False
Cls.Worksheets(1).Delete
Cls.Worksheets(1).Activate
 
'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA
Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Cls.SaveAs Chemin & "Toto" & Format(Date, "ddmmyyyy") & ".xlsx"
Cls.Close
Set Cls = Nothing
 
'On enregistre Recap dans Chemin sous ce format NomDDMMAAAA
Recap.SaveAs Chemin & "Recap" & Format(Date, "ddmmyyyy") & ".xlsx"
'Recap.Close
Set Recap = Nothing
Application.DisplayAlerts = True
End Sub
 
'Sub de préparation du classeur Récap
Sub PrepRecap(Wbk As Workbook, Sh As Worksheet)
 
With Wbk 'Nom des onglets + Position (+nom) des colonnes (constantes importées de la feuille de stats initiales)
    With .Sheets(1)
        .Name = "A"
        .Range("C1").Value = Sh.Range("A24")
        .Range("D1").Value = "b"
        .Range("G1").Value = "d"
        .Range("H1").Value = Sh.Range("A6")
        .Range("L1").Value = Sh.Range("A7")
        .Range("M1").Value = Sh.Range("A10")
        .Columns.AutoFit
    End With
    With .Sheets(2)
        .Name = "B"
        'aaa
        .Range("C1").Value = Sh.Range("A25")
        .Range("D1").Value = Sh.Range("A16")
        .Range("E1").Value = Sh.Range("A19")
        .Range("F1").Value = Sh.Range("A22")
        'bbb
        .Range("H1").Value = Sh.Range("A26")
        .Range("I1").Value = Sh.Range("A17")
        .Range("J1").Value = Sh.Range("A20")
        .Range("K1").Value = Sh.Range("A23")
        'ccc
        .Range("M1").Value = Sh.Range("A41")
        .Range("N1").Value = Sh.Range("A35")
        .Range("O1").Value = Sh.Range("A37")
        .Range("P1").Value = Sh.Range("A40")
         'ddd
        .Range("R1").Value = Sh.Range("A42")
        .Range("S1").Value = Sh.Range("A36")
        .Range("T1").Value = Sh.Range("A38")
        .Range("U1").Value = Sh.Range("A39")
        'eee
        .Range("W1").Value = Sh.Range("A70")
        .Range("X1").Value = Sh.Range("A71")
        .Range("Y1").Value = Sh.Range("A68")
        .Range("Z1").Value = Sh.Range("A69")
        .Columns.AutoFit
    End With
    With .Sheets(3)
        .Name = "C"
        .Range("B1").Value = "MC"
        .Range("C1").Value = "NC"
        .Columns.AutoFit
    End With
End With
End Sub
 
 
'Sub de transfert des données vers le classeur récap
Sub Transf(ByVal Patient As String, Wbk As Workbook, Sh As Worksheet, ByVal Lig As Long)
 
With Wbk 'Position et destination des données (variables importées du classeur Cls)
    With .Sheets(1)
        .Range("B" & Lig).Value = Patient
        .Range("C" & Lig).Value = Sh.Range("C24").Value
        .Range("D" & Lig).Value = Sh.Range("C18").Value
        .Range("G" & Lig).Value = Sh.Range("C15").Value
        .Range("H" & Lig).Value = Sh.Range("C6").Value
        .Range("L" & Lig).Value = Sh.Range("C7").Value
        .Range("M" & Lig).Value = Sh.Range("C10").Value
        .Columns.AutoFit
    End With
    With .Sheets(2)
        .Range("B" & Lig).Value = Patient
        'aaa
        .Range("C" & Lig).Value = Sh.Range("C25").Value
        .Range("D" & Lig).Value = Sh.Range("C16").Value
        .Range("E" & Lig).Value = Sh.Range("C19").Value
        .Range("F" & Lig).Value = Sh.Range("C22").Value
        'bbb
        .Range("H" & Lig).Value = Sh.Range("C26").Value
        .Range("I" & Lig).Value = Sh.Range("C17").Value
        .Range("J" & Lig).Value = Sh.Range("C20").Value
        .Range("K" & Lig).Value = Sh.Range("C23").Value
        .Columns.AutoFit
        'ccc
        .Range("M" & Lig).Value = Sh.Range("C41").Value
        .Range("N" & Lig).Value = Sh.Range("C35").Value
        .Range("O" & Lig).Value = Sh.Range("C37").Value
        .Range("P" & Lig).Value = Sh.Range("C40").Value
        'ddd
        .Range("R" & Lig).Value = Sh.Range("C42").Value
        .Range("S" & Lig).Value = Sh.Range("C36").Value
        .Range("T" & Lig).Value = Sh.Range("C38").Value
        .Range("U" & Lig).Value = Sh.Range("C39").Value
        'eee
        .Range("W" & Lig).Value = Sh.Range("C70").Value
        .Range("X" & Lig).Value = Sh.Range("C71").Value
        .Range("Y" & Lig).Value = Sh.Range("C68").Value
        .Range("Z" & Lig).Value = Sh.Range("C69").Value
        .Columns.AutoFit
    End With
    With .Sheets(3)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C18").Value
        .Range("C" & Lig).Value = Sh.Range("C19").Value
        .Columns.AutoFit
    End With
End With
End Sub

Bonsoir
Remplace la partie d'enregistrement

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
'....
Suff = Format(Date, "ddmmyyyy")
Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Doss = Chemin & "NOM" & Suff
If Dir(Doss, vbDirectory) = "" Then MkDir Doss
Chemin = Doss & "\"
'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA
Cls.SaveAs Chemin & "Toto" & Suff & ".xlsx"
Cls.Close
Set Cls = Nothing
'On enregistre Recap dans Chemin sous ce format NomDDMMAAAA
Recap.SaveAs Chemin & "Recap" & Suff & ".xlsx"
'.....

Et dans partie déclarations

Code:

1
2
Dim Chemin As String, Suff As String, Doss As String
'Partie déclarations

Bonjour,

Donc j'ai testé et ça marche comme je le souhaitais, beau travail merci. Pour finir en beauté, serait-il possible de fermer et sauver automatiquement le fichier contenant la macro une fois celle terminée (en écrasant les données préexistantes - pas de fenêtre de confirmation) et ensuite ouvrir le dossier créer par la macro.

Merci Bien.
Amitiés

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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
Sub ClasseurPatients()
Dim Cls As Workbook, Recap As Workbook
Dim Fe As Worksheet, FeAjout As Worksheet
Dim LastLig As Long, i As Long, j As Long
Dim Chemin As String
Dim Chemin As String, Suff As String, Doss As String
 
 
Application.ScreenUpdating = False
 
'adapter le nom de la feuille où se trouvent les valeurs
Set Fe = ThisWorkbook.Worksheets("Feuil1")
 
'crée le classeur récap avec 3 feuilles
Application.SheetsInNewWorkbook = 3
Set Recap = Workbooks.Add
 
'appel sub préparation classeur récap
PrepRecap Recap, Fe
 
'crée le classeur avec une seule feuille
Set Cls = Workbooks.Add(1)
j = 2
 
'défini la plage pour la récupération des valeurs
With Fe
    'Dernière ligne remplie de la colonne "B" (patients)
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
 
    'passe la plage de 119 en 119 (cellule A1 vide)
    For i = 2 To LastLig Step 120
 
        'ajoute une feuille au classeur en dernière position
        Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count))
        'renomme la feuille au nom du patient
        FeAjout.Name = .Range("B" & i).Value
 
        'puis les colle de A2 à C120 (cellule A1 vide)
        FeAjout.Range("A2:C120").Value = .Range("A" & i & ":C" & i + 120).Value
 
        'Ajustement automatiquement de la largeur des 3 première colonnes
        FeAjout.Columns("A:C").AutoFit
 
        'appel de la sub transfert données
        Transf .Range("B" & i).Value, Recap, FeAjout, j
        j = j + 1
    Next i
End With
Set Fe = Nothing
Set FeAjout = Nothing
 
'Supprime la feuille vide
Application.DisplayAlerts = False
Cls.Worksheets(1).Delete
Cls.Worksheets(1).Activate
 
 
'Options d'enregistrement dossier + fichiers
Suff = Format(Date, "ddmmyyyy")
Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Doss = Chemin & "NOM" & Suff
If Dir(Doss, vbDirectory) = "" Then MkDir Doss
Chemin = Doss & "\"
 
'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA
Cls.SaveAs Chemin & "Toto" & Suff & ".xlsx"
Cls.Close
Set Cls = Nothing
 
'On enregistre Recap dans Chemin sous ce format NomDDMMAAAA
Recap.SaveAs Chemin & "Recap" & Suff & ".xlsx"
Set Recap = Nothing
 
 
Application.DisplayAlerts = True
End Sub
 
 
 
 
 
'Sub de préparation du classeur Récap
Sub PrepRecap(Wbk As Workbook, Sh As Worksheet)
 
With Wbk 'Nom des onglets + Position (+nom) des colonnes (constantes importées de la feuille de stats initiales)
    With .Sheets(1)
        .Name = "A"
        .Range("C1").Value = Sh.Range("A24")
        .Range("D1").Value = "b"
        .Range("G1").Value = "d"
        .Range("H1").Value = Sh.Range("A6")
        .Range("L1").Value = Sh.Range("A7")
        .Range("M1").Value = Sh.Range("A10")
        .Columns.AutoFit
    End With
    With .Sheets(2)
        .Name = "B"
        'aaa
        .Range("C1").Value = Sh.Range("A25")
        .Range("D1").Value = Sh.Range("A16")
        .Range("E1").Value = Sh.Range("A19")
        .Range("F1").Value = Sh.Range("A22")
        'bbb
        .Range("H1").Value = Sh.Range("A26")
        .Range("I1").Value = Sh.Range("A17")
        .Range("J1").Value = Sh.Range("A20")
        .Range("K1").Value = Sh.Range("A23")
        'ccc
        .Range("M1").Value = Sh.Range("A41")
        .Range("N1").Value = Sh.Range("A35")
        .Range("O1").Value = Sh.Range("A37")
        .Range("P1").Value = Sh.Range("A40")
         'ddd
        .Range("R1").Value = Sh.Range("A42")
        .Range("S1").Value = Sh.Range("A36")
        .Range("T1").Value = Sh.Range("A38")
        .Range("U1").Value = Sh.Range("A39")
        'eee
        .Range("W1").Value = Sh.Range("A70")
        .Range("X1").Value = Sh.Range("A71")
        .Range("Y1").Value = Sh.Range("A68")
        .Range("Z1").Value = Sh.Range("A69")
        .Columns.AutoFit
    End With
    With .Sheets(3)
        .Name = "C"
        .Range("B1").Value = "MC"
        .Range("C1").Value = "NC"
        .Columns.AutoFit
    End With
End With
End Sub
 
 
'Sub de transfert des données vers le classeur récap
Sub Transf(ByVal Patient As String, Wbk As Workbook, Sh As Worksheet, ByVal Lig As Long)
 
With Wbk 'Position et destination des données (variables importées du classeur Cls)
    With .Sheets(1)
        .Range("B" & Lig).Value = Patient
        .Range("C" & Lig).Value = Sh.Range("C24").Value
        .Range("D" & Lig).Value = Sh.Range("C18").Value
        .Range("G" & Lig).Value = Sh.Range("C15").Value
        .Range("H" & Lig).Value = Sh.Range("C6").Value
        .Range("L" & Lig).Value = Sh.Range("C7").Value
        .Range("M" & Lig).Value = Sh.Range("C10").Value
        .Columns.AutoFit
    End With
    With .Sheets(2)
        .Range("B" & Lig).Value = Patient
        'aaa
        .Range("C" & Lig).Value = Sh.Range("C25").Value
        .Range("D" & Lig).Value = Sh.Range("C16").Value
        .Range("E" & Lig).Value = Sh.Range("C19").Value
        .Range("F" & Lig).Value = Sh.Range("C22").Value
        'bbb
        .Range("H" & Lig).Value = Sh.Range("C26").Value
        .Range("I" & Lig).Value = Sh.Range("C17").Value
        .Range("J" & Lig).Value = Sh.Range("C20").Value
        .Range("K" & Lig).Value = Sh.Range("C23").Value
        .Columns.AutoFit
        'ccc
        .Range("M" & Lig).Value = Sh.Range("C41").Value
        .Range("N" & Lig).Value = Sh.Range("C35").Value
        .Range("O" & Lig).Value = Sh.Range("C37").Value
        .Range("P" & Lig).Value = Sh.Range("C40").Value
        'ddd
        .Range("R" & Lig).Value = Sh.Range("C42").Value
        .Range("S" & Lig).Value = Sh.Range("C36").Value
        .Range("T" & Lig).Value = Sh.Range("C38").Value
        .Range("U" & Lig).Value = Sh.Range("C39").Value
        'eee
        .Range("W" & Lig).Value = Sh.Range("C70").Value
        .Range("X" & Lig).Value = Sh.Range("C71").Value
        .Range("Y" & Lig).Value = Sh.Range("C68").Value
        .Range("Z" & Lig).Value = Sh.Range("C69").Value
        .Columns.AutoFit
    End With
    With .Sheets(3)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C18").Value
        .Range("C" & Lig).Value = Sh.Range("C19").Value
        .Columns.AutoFit
    End With
End With
End Sub

Bonjour
Pour ouvrir un dossier (entre autre)

Code:

Shell "Explorer.exe """ & TonDossier & """, vbNormalFocus"

Pour enregistrer et fermer le classeur contenant la macro

Code:

ThisWorkbook.Close True

Ou bien pour enregistrer et fermer excel

Code:

1
2
ThisWorkbook.Save
Application.Quit

Maintenant, tu veux combiner les 2 mais attention quand même:
Si tu ferme le classeur contenant le code en premier, comment veux tu terminer l'exécution du code pour ouvrir le dossier crée (le classeur contenant la macro étant fermé, la macro est déjà "morte")

Ci-Joint Code complet (pour être utile aux lecteurs)

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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
Sub ClasseurPatients()
Dim Cls As Workbook, Recap As Workbook
Dim Fe As Worksheet, FeAjout As Worksheet
Dim LastLig As Long, i As Long, j As Long
Dim Chemin As String, Suff As String, Doss As String
 
Application.ScreenUpdating = False
'adapter le nom de la feuille où se trouvent les valeurs
Set Fe = ThisWorkbook.Worksheets("Feuil1")
'crée le classeur récap avec 3 feuilles
Application.SheetsInNewWorkbook = 3
Set Recap = Workbooks.Add
'appel sub préparation classeur récap
PrepRecap Recap, Fe
'crée le classeur avec une seule feuille
Set Cls = Workbooks.Add(1)
j = 2
'défini la plage pour la récupération des valeurs
With Fe
    'Dernière ligne remplie de la colonne "B" (patients)
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
    'passe la plage de 119 en 119 (cellule A1 vide)
    For i = 2 To LastLig Step 120
        'ajoute une feuille au classeur en dernière position
        Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count))
        'renomme la feuille au nom du patient
        FeAjout.Name = .Range("B" & i).Value
        'puis les colle de A2 à C120 (cellule A1 vide)
        FeAjout.Range("A2:C120").Value = .Range("A" & i & ":C" & i + 120).Value
        'Ajustement automatiquement de la largeur des 3 première colonnes
        FeAjout.Columns("A:C").AutoFit
        'appel de la sub transfert données
        Transf .Range("B" & i).Value, Recap, FeAjout, j
        j = j + 1
    Next i
End With
Set Fe = Nothing
Set FeAjout = Nothing
'Supprime la feuille vide
Application.DisplayAlerts = False
Cls.Worksheets(1).Delete
Cls.Worksheets(1).Activate
'Options d'enregistrement dossier + fichiers
Suff = Format(Date, "ddmmyyyy")
Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Doss = Chemin & "NOM" & Suff
If Dir(Doss, vbDirectory) = "" Then MkDir Doss
Chemin = Doss & "\"
'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA et on le ferme
Cls.SaveAs Chemin & "Toto" & Suff & ".xlsx"
Cls.Close
Set Cls = Nothing
'On enregistre Recap dans Chemin sous ce format NomDDMMAAAA et on le ferme
Recap.SaveAs Chemin & "Recap" & Suff & ".xlsx"
Recap.Close
Set Recap = Nothing
Application.DisplayAlerts = True
'On ouvre Doss
Shell "Explorer.exe """ & Doss & """, vbNormalFocus"
'On enregistre et ferme le fichier courant
ThisWorkbook.Save
Application.Quit
End Sub
 
'Sub de préparation du classeur Récap
Sub PrepRecap(Wbk As Workbook, Sh As Worksheet)
 
With Wbk
    With .Sheets(1)
        .Name = "A"
        .Range("B1").Value = Sh.Range("A8")
        .Range("D1").Value = Sh.Range("A10")
    End With
    With .Sheets(2)
        .Name = "B"
        .Range("B1").Value = Sh.Range("A14")
    End With
    With .Sheets(3)
        .Name = "C"
        .Range("B1").Value = Sh.Range("A20")
        .Range("C1").Value = Sh.Range("A21")
    End With
End With
End Sub
 
'Sub de transfert des données vers le classeur récap
Sub Transf(ByVal Patient As String, Wbk As Workbook, Sh As Worksheet, ByVal Lig As Long)
 
With Wbk
    With .Sheets(1)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C6").Value
        .Range("D" & Lig).Value = Sh.Range("C8").Value
    End With
    With .Sheets(2)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C12").Value
    End With
    With .Sheets(3)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C18").Value
        .Range("C" & Lig).Value = Sh.Range("C19").Value
    End With
End With
End Sub

13/03/2011, 14h48
roberto75

C'est noté, on ouvre le dossier puis on ferme le classeur contenant la macro.
Par contre j'ai soucis concernant le code ci-dessus.

Le classeur contenant la macro se trouve sur le bureau. Lorsque je l'exécute, j'ai une petite erreur qui apparaît. L'explorateur windows m'annonce que "le chemin d'accès vbNormalFocus n'existe pas ou n'est pas un répertoire." les fichiers Toto et Recap sont bien présents dans un dossier sur le bureau, mais le dossier ne s'ouvre pas.
13/03/2011, 15h33
mercatog

J'ai fais le test avec fichier sur le bureau et ça fonctionne (Vista/ Excel 2007)
13/03/2011, 17h30
roberto75
J'ai revérifié le code et ça ne semble pas marcher sous ma configuration (Xp sp2, Excel 2007).

Par contre, en modifiant le code avec ceci, ça marche.
Code:

1 2 'On ouvre Doss ShellID = Shell("Explorer.exe """ & Doss & """", vbNormalFocus)
13/03/2011, 19h03
mercatog
Effectivement, c'est mieux et plus propre.
Sinon, une légère modification à la fin du code pour améliorer l'aspect visuel
On enregistre le fichier courant
On ouvre le dossier
On quitte Excel
Code:

1 2 3 4 5 6 7 8 9 '.... '.... 'On enregistre le fichier courant ThisWorkbook.Save 'On ouvre Doss ShellID = Shell("Explorer.exe """ & Doss & """", vbNormalFocus) 'On quitte Excel Application.Quit End Sub

Bonsoir,
Je pense que maintenant la macro est au point, elle est sûrement perfectible mais à ce stade elle me convient parfaitement. Elle fait exactement ce que j'attends d'elle et elle le fait très bien. En tout cas un grand merci à vous deux sans qui cette macro n'aurait jamais pu voir le jour. A bientôt.

Ci-dessous le code final de la macro commenté.

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
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
Sub ClasseurPatients()
Dim Cls As Workbook, Recap As Workbook
Dim Fe As Worksheet, FeAjout As Worksheet
Dim LastLig As Long, i As Long, j As Long
Dim Chemin As String, Suff As String, Doss As String
 
Application.ScreenUpdating = False
'adapter le nom de la feuille où se trouvent les valeurs
Set Fe = ThisWorkbook.Worksheets("Feuil1")
'crée le classeur récap avec 3 feuilles
Application.SheetsInNewWorkbook = 3
Set Recap = Workbooks.Add
'appel sub préparation classeur récap
PrepRecap Recap, Fe
'crée le classeur avec une seule feuille
Set Cls = Workbooks.Add(1)
j = 2
'défini la plage pour la récupération des valeurs
With Fe
    'Dernière ligne remplie de la colonne "B" (patients)
    LastLig = .Cells(.Rows.Count, "B").End(xlUp).Row
    'passe la plage de 119 en 119 (cellule A1 vide)
    For i = 2 To LastLig Step 120
        'ajoute une feuille au classeur en dernière position
        Set FeAjout = Cls.Worksheets.Add(After:=Cls.Worksheets(Worksheets.Count))
        'renomme la feuille au nom du patient
        FeAjout.Name = .Range("B" & i).Value
        'puis les colle de A2 à C120 (cellule A1 vide)
        FeAjout.Range("A2:C120").Value = .Range("A" & i & ":C" & i + 120).Value
        'Ajustement automatiquement de la largeur des 3 première colonnes
        FeAjout.Columns("A:C").AutoFit
        'appel de la sub transfert données
        Transf .Range("B" & i).Value, Recap, FeAjout, j
        j = j + 1
    Next i
End With
Set Fe = Nothing
Set FeAjout = Nothing
'Supprime la feuille vide
Application.DisplayAlerts = False
Cls.Worksheets(1).Delete
Cls.Worksheets(1).Activate
'Options d'enregistrement dossier + fichiers
Suff = Format(Date, "ddmmyyyy")
Chemin = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Doss = Chemin & "NOM" & Suff
If Dir(Doss, vbDirectory) = "" Then MkDir Doss
Chemin = Doss & "\"
'On enregistre Cls dans Chemin sous ce format NomDDMMAAAA et on le ferme
Cls.SaveAs Chemin & "Toto" & Suff & ".xlsx"
Cls.Close
Set Cls = Nothing
'On enregistre Recap dans Chemin sous ce format NomDDMMAAAA et on le ferme
Recap.SaveAs Chemin & "Recap" & Suff & ".xlsx"
Recap.Close
Set Recap = Nothing
Application.DisplayAlerts = True
'On ouvre Doss
Shell "Explorer.exe """ & Doss & """, vbNormalFocus"
'On enregistre le fichier courant
ThisWorkbook.Save
'On ouvre Doss
ShellID = Shell("Explorer.exe """ & Doss & """", vbNormalFocus)
'On quitte Excel
Application.Quit
End Sub
 
'Sub de préparation du classeur Récap
Sub PrepRecap(Wbk As Workbook, Sh As Worksheet)
 
With Wbk
    With .Sheets(1)
        .Name = "A"
        .Range("B1").Value = Sh.Range("A8")
        .Range("D1").Value = Sh.Range("A10")
    End With
    With .Sheets(2)
        .Name = "B"
        .Range("B1").Value = Sh.Range("A14")
    End With
    With .Sheets(3)
        .Name = "C"
        .Range("B1").Value = Sh.Range("A20")
        .Range("C1").Value = Sh.Range("A21")
    End With
End With
End Sub
 
'Sub de transfert des données vers le classeur récap
Sub Transf(ByVal Patient As String, Wbk As Workbook, Sh As Worksheet, ByVal Lig As Long)
 
With Wbk
    With .Sheets(1)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C6").Value
        .Range("D" & Lig).Value = Sh.Range("C8").Value
    End With
    With .Sheets(2)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C12").Value
    End With
    With .Sheets(3)
        .Range("A" & Lig).Value = Patient
        .Range("B" & Lig).Value = Sh.Range("C18").Value
        .Range("C" & Lig).Value = Sh.Range("C19").Value
    End With
End With
End Sub