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