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
187
188
189
190
191
| Option Explicit
Option Base 1
Sub essai()
Dim dico_dates As Variant
Set dico_dates = CreateObject("Scripting.Dictionary")
Dim tablo_wks()
Dim wks As Worksheet
Dim n As Byte
Dim derdate As Integer, i As Integer
n = 0
Worksheets("BILAN").Range("C2").CurrentRegion.ClearContents
'Création du tableau des feuilles du classseur
For Each wks In ThisWorkbook.Worksheets
With wks
If InStr(.Name, "BILAN") = 0 Then
n = n + 1
ReDim Preserve tablo_wks(1 To n)
tablo_wks(n) = .Name
'nom de la feuille en en-tête de champ dans la feuille billan
Worksheets("BILAN").Cells(1, 2 + n).Value = .Name
derdate = .Cells(.Rows.Count, 1).End(xlUp).Row
derdate = WorksheetFunction.Max(derdate, 2)
'Création des noms utilisés dans la fonction Sommeprod
ThisWorkbook.Names.Add Name:="liste_dates_" & .Name, RefersTo:=.Range("A2", .Cells(derdate, 1))
ThisWorkbook.Names.Add Name:="liste_collab_" & .Name, RefersTo:=.Range("liste_dates_" & .Name).Offset(0, 1)
ThisWorkbook.Names.Add Name:="liste_heures_" & .Name, RefersTo:=.Range("liste_dates_" & .Name).Offset(0, 5)
'Dictionnaire des dates pour l'ensemble des feuilles
For i = 2 To derdate
If Not dico_dates.Exists(.Cells(i, 1).Value) Then dico_dates.Add .Cells(i, 1).Value, .Cells(i, 1).Value
Next i
End If
End With
Next wks
Dim temp As Variant
temp = dico_dates.items
'Réinitialisation et Libération de la variable
dico_dates.RemoveAll
Set dico_dates = Nothing
'Tri des dates par ordre coissant
Call Tri(temp, LBound(temp), UBound(temp))
Dim t As Variant
Dim c As Range
Dim firstAddress As String
Dim p As Integer, n_occ As Byte
Dim tablo() As Variant
Dim cell_dest As Range
'nombre de lignes informées dans la feuille "BILAN"
n_occ = 0
'Balayage des dates
For Each t In temp
'Debug.Print "Valeur de t : " & t
'Recjerche de la date dans chaque feuille et eport du nom de collaborateur associé
For Each wks In ThisWorkbook.Worksheets
With wks
If InStr(.Name, "BILAN") = 0 Then
p = 0
With .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
'Trouve la date et l'inscrit dans la feuille bilan
Set c = .Find(t, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
'incrémentation
p = p + 1
With c
'test 1er enregistrement
If p > 1 Then
'test si doublon
If CDate(.Value) <> tablo(1, p - 1) Or .Offset(0, 1).Value <> tablo(2, p - 1) Then
'report de la date et du nom associé
ReDim Preserve tablo(1 To 2, 1 To p)
tablo(1, p) = CDate(.Value)
tablo(2, p) = .Offset(0, 1).Value
Debug.Print tablo(2, p)
Else
p = p - 1
End If
Else
ReDim tablo(1 To 2, 1)
tablo(1, p) = CDate(.Value)
tablo(2, p) = .Offset(0, 1).Value
End If
'Debug.Print p
'Debug.Print tablo(1, p)
'Debug.Print tablo(2, p)
End With
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
Set c = Nothing
End With
End If
End With
Next wks
'Destination du tableau date/collaborateur(s) dans la feuille BILAN
With Worksheets("Bilan")
Set cell_dest = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
End With
cell_dest.Resize(UBound(tablo, 2), UBound(tablo, 1)).Value = WorksheetFunction.Transpose(tablo)
'nombre d'occurences incrémentées
n_occ = n_occ + UBound(tablo, 2)
Erase tablo
Next t
'Debug.Print "n occ : " & n_occ
Dim j As Byte
Dim laréf As String
Dim d As Range
Dim cells_formules As Range
With Worksheets("BILAN")
For j = LBound(tablo_wks, 1) To UBound(tablo_wks, 1)
laréf = tablo_wks(j)
'Debug.Print laréf
'Debug.Print .Range(.Cells(2, j + 2), .Cells(n_occ + 1, j + 2)).Address
'Adresse des formules à créer
Set cells_formules = .Range(.Cells(2, j + 2), .Cells(n_occ + 1, j + 2))
For Each d In cells_formules
With d
'Formule Sommeprod avec comme variables le nom de la feuille et ceux des champs associés
.FormulaR1C1 = "=SUMPRODUCT((liste_dates_" & laréf & "=RC[-" & j + 1 & "]+0) *(liste_collab_" & laréf & "=RC[-" & j & "])*(liste_heures_" & laréf & "))"
'Collage spécial valeurs (astuce du grand mercatog que je salue au passage)
.Value = .Value
'Effacement si valeur = 0
If .Value = 0 Then .ClearContents
End With
Next d
'libération de la variable
Set cells_formules = Nothing
Next j
End With
End Sub
'-----------------------------------------------------------------------
'Procédure récursive de tri d'un dictionnaire
Sub Tri(a As Variant, gauc As Long, droi As Long) ' Quick sort
Dim g As Long, d As Long
Dim ref As Variant
Dim t As Variant
ref = a((gauc + droi) \ 2)
g = gauc: d = droi
Do
Do While a(g) < ref
g = g + 1
Loop
Do While ref < a(d)
d = d - 1
Loop
If g <= d Then
t = a(g)
a(g) = a(d)
a(d) = t
g = g + 1
d = d - 1
End If
Loop While g <= d
If g < droi Then Call Tri(a, g, droi)
If gauc < d Then Call Tri(a, gauc, d)
End Sub |
