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 SOUS_DESTINATION_TRIPLET()
Dim Type_SD As String 'Fournit le type d'établissement
Dim Sce_SD As String 'Fournit le service
Dim Nature_SD As String 'Fournit la nature
Dim Sousdestination As String 'Fournit la sous-destination
Dim TRIPLET_SD As Range 'Fournit la plage de données
Dim Cpt As Long 'Compteur de cellules contenant des croisements
Dim c As Object 'Elément dans la plage de données
Dim CPT2 As Long 'Compteur pour la restitution
Dim Numline As Long 'Fournit le nombre de lignes de la plage
Dim Numcolonne As Long 'Fournit le nombre de colonnes de la plage
Dim Valeurlue As String 'Fournit le contenu de la cellule active
Dim Seekunderscore As Variant 'Fournit la position du "_" dans la chaîne
Dim Nbcaractere As Integer 'Fournit le nombre de caracatères dans la chaîne
Dim Nbpositionsnature As Integer 'Fournit le nombre de caractères utilisés pour coder la sous-destination
Dim Chainesce As String 'Fournit la chaîne pour récupérer dynamiquement le service
Dim Duree As String 'Durée du traitement
Dim Duree_deb As Date 'Durée du traitement
Dim Duree_fin As Date 'Durée du traitement
Dim Entete As Range 'Entête du tableau de restitution
Application.ScreenUpdating = False
Duree_deb = Now
ActiveWorkbook.Worksheets("Restitution").Select
'Suppression des données sur la feuille "Restitution" avant nouvel import
With Worksheets("Restitution").Range("B:B,C:C,D:D,E:E")
.Clear
End With
'Sélection de la feuille source
ActiveWorkbook.Worksheets("Source").Select
ActiveSheet.Cells(1400, 2).Select
'Insertion du type d'établissement
ActiveCell.Value = "TYPE ETABLISSEMENT"
ActiveCell.Offset(0, 1).Select
'Insertion du service
ActiveCell.Value = "SERVICE"
ActiveCell.Offset(0, 1).Select
'Insertion de la nature
ActiveCell.Value = "NATURE"
ActiveCell.Offset(0, 1).Select
'Insertion de la sous-destination
ActiveCell.Value = "SOUS-DESTINATION"
ActiveCell.Offset(1, -3).Select
'Sélection de la plage de données contenant les triplets "TRIPLET_SD
Application.Goto Reference:="TRIPLET_SD"
CPT2 = 1401
'Nombre de ligne de la plage de données
'Numline = Range("TRIPLET_SD").Rows.Count
'Nombre de colonnes de la plage de données
'Numcolonne = Range("TRIPLET_SD").Columns.Count
'Décompte du nombre de croisement nature*service
'For Each c In Range("TRIPLET_SD")
'If c.Value <> "" Then
'CPT = CPT + 1
'End If
'Next c
'Affichage du nombre de triplets de la base de données
'MsgBox " Il y'a " & CPT & " triplets"
For Each c In Range("TRIPLET_SD")
Valeurlue = c
If Valeurlue <> "" Then
'Affichage des coordonnées de la première cellule de la plage
'MsgBox ActiveCell.Address
'Affichage du contenu de la première cellule de la plage
'MsgBox ActiveCell.Value
'Lecture du contenu de la cellule active
Seekunderscore = InStr(1, Valeurlue, "_")
'Affichage de la postion de "_"
'MsgBox "Position du underscore " & Seekunderscore
'Lecture du type d'établissement dans la chaîne codée
Nbcaractere = Len(Valeurlue)
Nbpositionsnature = Nbcaractere - (Nbcaractere - (Seekunderscore - 1))
'MsgBox Nbpositionsnature
Type_SD = Left(Valeurlue, Nbpositionsnature)
'Affichage du type d'établissment
'MsgBox "le type d'établissement est " & Type_SD
'Lecture de la nouvelle chaîne tronquée, sans le type d'établissement
Chainesce = Right(Valeurlue, (Nbcaractere - Seekunderscore))
Seekunderscore = InStr(1, Chainesce, "_")
'Lecture dynamique du service dans la nouvelle chaîne
Sce_SD = Left(Chainesce, (Len(Chainesce) - (Len(Chainesce) - (Seekunderscore - 1))))
'Affichage du service
'MsgBox "le service est " & Sce_SD
'Lecture de la nature dans la chaîne codée
Nature_SD = Left(Right(Valeurlue, 12), 8)
'Affichage de la nature
'MsgBox "la nature est " & Nature_SD
'Recherche de la position de "_" à partir de la fin dans la chaîne codée
Seekunderscore = InStrRev(Valeurlue, "_", , vbTextCompare)
'Affichage de la postion de "_"
'MsgBox "Position du underscore " & Seekunderscore
'Nbcaractere = Len(Valeurlue)
'MsgBox "La chaîne comporte " & Nbcaractere & " caractères"
Nbpositionsnature = Nbcaractere - Seekunderscore
'MsgBox "La nature est codée sur " & Nbpositionsnature & " unités"
'Lecture de la sous-destination dans la chaîne de codes
Sousdestination = Right(Valeurlue, Nbpositionsnature)
'MsgBox "la sous-destination est " & Sousdestination
'MsgBox ActiveCell.Address
'ActiveWorkbook.Worksheets("Restitution").Select
ActiveSheet.Cells(CPT2, 2).Select
ActiveCell.Value = Type_SD
'MsgBox " la première cell de restit" & ActiveCell.Address
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sce_SD
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Nature_SD
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Sousdestination
ActiveCell.Offset(1, -3).Select
'MsgBox ActiveCell.Address
CPT2 = CPT2 + 1
End If
Next c
'Export des données vers la feuille restitution
Range("B1400:E65536").Cut (Worksheets("Restitution").Range("B2"))
ActiveWorkbook.Worksheets("Restitution").Select
'Sélection de l'entête du tableau
Worksheets("Restitution").Range("B2:E2").Select
'Mise en gras de l'entête du tableau
Set Entete = Worksheets("Restitution").Range("B2:E2")
'Entete = Range("B2:E2")
'MsgBox Entete
Entete.Font.Bold = True
With Entete
'On centre horizontalement les cellules
.HorizontalAlignment = xlCenter
'On centre verticalement les cellules
.VerticalAlignment = xlCenter
'Alignement du texte dans les cellules, retour à la ligne
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
'Ajustement des cellules
.ShrinkToFit = False
.ReadingOrder = xlContext
'Fusion des cellules
.MergeCells = False
End With
'Largeur des colonnes
Columns("B:B").ColumnWidth = 15.71
Columns("E:E").ColumnWidth = 12.71
With Entete.Interior
'Couleur arrière-plan cellule
.ColorIndex = 37
'Arrière-plan de la cellule
.Pattern = xlSolid
End With
'Sélection de la colonne des services
Worksheets("Restitution").Range("C1:C65536").Select
'Mise au format du code service sur trois caractères
Range("C1:C65536").NumberFormat = "000"
Duree_fin = Now
'Calcul du temps de traitement
Duree = Format(Duree_fin - Duree_deb, "hh:mm:ss")
Duree = Minute(Duree)
MsgBox "La récupération des sous-destinations avec type d'établissement, service et nature est terminée!!" _
& vbCrLf + "La récupération s'est effectuée en " & Duree & " mn"
Application.ScreenUpdating = True
End Sub |
