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 |
Partager