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 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262
| Option Compare Database
Option Explicit
Public Sub RepartirTravail()
'Le sub principal qui appel les autres
'Vous pouvez l'utiliser directement ou l'appeler à partir d'un formulaire
ViderEtRemplirLaTable
DiviserTache
RemplirControl
End Sub
Private Function fuControl() As Long
'Fonction qui retourne le nombre de superviseurs nécessaire
fuControl = fRoundUp(DSum("Work_Rate", "T_Work")) ' À modifier avec le nom de votre requête mon point 1
End Function
Private Function fRoundUp(NbrToRound As Variant) As Long
'Fonction qui arrondi en haut
fRoundUp = 0
If Not IsNull(NbrToRound) Then
fRoundUp = -Int(-NbrToRound)
End If
End Function
Private Function AddRemplirReste(rst As DAO.Recordset, sWork_FK As Variant, lRate As Long) As Long
'Fonction qui inscrit les employés dans superviseurs incomplets
On Error GoTo gestion_err
Dim lReste As Long
rst.Edit
If lRate > 100 - rst(2) Then
lReste = lRate - (100 - rst(2))
rst(1) = rst(1) & sWork_FK & "(" & 100 - rst(2) & "%)"
rst(2) = 100
rst.Update
rst.MoveNext
Else
rst(1) = rst(1) & sWork_FK & "(" & lRate & "%)"
lReste = 0
rst(2) = rst(2) + lRate
rst.Update
End If
AddRemplirReste = lReste
Sortie:
Exit Function
On Error Resume Next
gestion_err:
MsgBox "Erreur imprévue dans la sub AddRemplirReste" _
& Chr(13) & Err.Description _
& Chr(13) & "Erreur # " & Err.Number, vbCritical
Resume Sortie
End Function
Private Sub ViderEtRemplirLaTable()
'Sub qui inscrit les enregistrements nécessaires pour la répartitions
On Error GoTo gestion_err
Dim db As DAO.Database: Set db = CurrentDb
Dim rst As DAO.Recordset
Dim strSQL As String
Dim l As Long
Dim i As Long
strSQL = "DELETE T_Work_Control.* FROM T_Work_Control;"
db.Execute strSQL, dbFailOnError
l = fuControl()
strSQL = "SELECT T_Work_Control.* FROM T_Work_Control;"
Set rst = db.OpenRecordset(strSQL, 2, 512)
For i = 1 To l
rst.AddNew
rst("Control_ID") = i
rst.Update
Next i
Sortie:
Exit Sub
On Error Resume Next
rst.Close
Set rst = Nothing
Set db = Nothing
gestion_err:
MsgBox "Erreur imprévue dans la sub ViderEtRemplirLaTable" _
& Chr(13) & Err.Description _
& Chr(13) & "Erreur # " & Err.Number, vbCritical
Resume Sortie
End Sub
Private Sub DiviserTache()
'Sub qui divise les tâches
On Error GoTo gestion_err
Dim db As DAO.Database: Set db = CurrentDb
Dim rst As DAO.Recordset
Dim strSQL As String
Dim c As Currency
strSQL = "DELETE T_Work_Temp.* FROM T_Work_Temp;"
db.Execute strSQL, dbFailOnError
'Ici vous devrez modifier le select pour récupérer vos données.
'Pour mon exemple je récupère un nom qui est unique et le ratio
strSQL = "SELECT T_Work.Work_ID, T_Work.Work_Rate FROM T_Work " _
& "ORDER BY T_Work.Work_Rate DESC;"
Set rst = db.OpenRecordset(strSQL, 4, 512)
Do While Not rst.EOF
c = rst(1) - 1
If c >= 0 Then
strSQL = "INSERT INTO T_Work_Temp ( Work_ID, Work_Rate ) " _
& "VALUES('" & rst(0) & "', 1);"
db.Execute strSQL, dbFailOnError
If c > 0 Then
strSQL = "INSERT INTO T_Work_Temp ( Work_ID, Work_Rate ) " _
& "VALUES('" & rst(0) & "', " & rst(1) - 1 & ");"
db.Execute strSQL, dbFailOnError
End If
Else
strSQL = "INSERT INTO T_Work_Temp ( Work_ID, Work_Rate ) " _
& "VALUES('" & rst(0) & "', " & rst(1) & ");"
db.Execute strSQL, dbFailOnError
End If
rst.MoveNext
Loop
Sortie:
Exit Sub
On Error Resume Next
rst.Close
Set rst = Nothing
Set db = Nothing
gestion_err:
MsgBox "Erreur imprévue dans la sub DiviserTache" _
& Chr(13) & Err.Description _
& Chr(13) & "Erreur # " & Err.Number, vbCritical
Resume Sortie
End Sub
Private Sub RemplirTableau(Tableau() As Variant)
'Sub qui popule le tableau nécessaire pour la répartition
'Basé sur la table de mon point 4
On Error GoTo gestion_err
Dim db As DAO.Database: Set db = CurrentDb
Dim rst As DAO.Recordset
Dim strSQL As String
Dim l As Long
l = DCount("*", "T_Work_Temp")
ReDim Tableau(l - 1, 3)
strSQL = "SELECT T_Work_Temp.Work_ID, T_Work_Temp.Work_Rate " _
& "FROM T_Work_Temp ORDER BY T_Work_Temp.Work_Rate DESC;"
Set rst = db.OpenRecordset(strSQL, 4, 512)
l = 0
Do While Not rst.EOF
Tableau(l, 0) = l
Tableau(l, 1) = "(" & rst(0) & "/" & DLookup("Work_Rate", "T_Work", "[Work_ID]=" & Chr(34) & rst(0) & Chr(34)) & ")"
Tableau(l, 2) = rst(1) * 100
Tableau(l, 3) = 0
l = l + 1
rst.MoveNext
Loop
Sortie:
Exit Sub
On Error Resume Next
rst.Close
Set rst = Nothing
Set db = Nothing
gestion_err:
MsgBox "Erreur imprévue dans la sub RemplirTableau" _
& Chr(13) & Err.Description _
& Chr(13) & "Erreur # " & Err.Number, vbCritical
Resume Sortie
End Sub
Private Sub RemplirControl()
'Sub qui inscrit les employés à leurs superviseurs
'Table de mon point 8
On Error GoTo gestion_err
Dim db As DAO.Database: Set db = CurrentDb
Dim rst As DAO.Recordset
Dim strSQL As String
Dim vaTableau() As Variant
Dim l As Long
Dim lRate As Long
RemplirTableau vaTableau
strSQL = "SELECT Control_ID, Work_FK, Rate " _
& "FROM T_Work_Control WHERE Rate = 0;"
Set rst = db.OpenRecordset(strSQL, 2, 512)
For l = 0 To UBound(vaTableau)
If Not rst.EOF Then
If vaTableau(l, 2) = 100 And vaTableau(l, 3) = 0 Then
rst.Edit
rst(1) = vaTableau(l, 1) & "(100%)"
rst(2) = 100
rst.Update
vaTableau(l, 3) = 100
rst.MoveNext
ElseIf vaTableau(l, 3) = 0 Then
rst.Edit
rst(1) = vaTableau(l, 1) & "(" & vaTableau(l, 2) & "%)"
rst(2) = vaTableau(l, 2)
rst.Update
vaTableau(l, 3) = vaTableau(l, 2)
AddRemplir rst, vaTableau, 100 - rst(2)
rst.MoveNext
End If
End If
Next
rst.Close
Set rst = Nothing
strSQL = "SELECT Control_ID, Work_FK, Rate " _
& "FROM T_Work_Control WHERE Rate < 100 " _
& "ORDER BY T_Work_Control.Rate;"
Set rst = db.OpenRecordset(strSQL, 2, 512)
For l = 0 To UBound(vaTableau)
If vaTableau(l, 2) <> vaTableau(l, 3) Then
lRate = vaTableau(l, 2)
Do While lRate > 0
lRate = AddRemplirReste(rst, vaTableau(l, 1), lRate)
If lRate = 0 Then: vaTableau(l, 3) = vaTableau(l, 2)
Loop
End If
Next
Sortie:
Exit Sub
On Error Resume Next
rst.Close
Set rst = Nothing
Set db = Nothing
gestion_err:
MsgBox "Erreur imprévue dans la sub RemplirLesComplets" _
& Chr(13) & Err.Description _
& Chr(13) & "Erreur # " & Err.Number, vbCritical
Resume Sortie
End Sub
Private Sub AddRemplir(rst As DAO.Recordset, vaTableau() As Variant, Limite As Long)
'Sub récursive pour compléter la sub RemplirControl
On Error GoTo gestion_err
Dim l As Long
Dim Trouve As Boolean
For l = LBound(vaTableau) To UBound(vaTableau)
If vaTableau(l, 2) <= Limite And vaTableau(l, 3) = 0 Then
Trouve = True
rst.Edit
rst(1) = rst(1) & vaTableau(l, 1) & "(" & vaTableau(l, 2) & "%)"
rst(2) = vaTableau(l, 2) + rst(2)
rst.Update
vaTableau(l, 3) = vaTableau(l, 2)
Limite = 100 - rst(2)
If Trouve Then: AddRemplir rst, vaTableau, Limite
End If
Next
Sortie:
Exit Sub
On Error Resume Next
gestion_err:
MsgBox "Erreur imprévue dans la sub AddRemplir" _
& Chr(13) & Err.Description _
& Chr(13) & "Erreur # " & Err.Number, vbCritical
Resume Sortie
End Sub |
Partager