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 |
