Accessを使った「担当割り」の自動化

やりたいこと

たまたま業務で表題機能を実装することになったんですが、ネットで調べてもなかなか思うようなヒントが得られず
仕方ないので、自分であれこれ試行錯誤した結果のメモ。

要は、複数のメンバーに重み付けをして、案件ごとに自動的に担当割する仕組みを作るというものです。
案件が発生するたびに都度Access上の処理を動かし、担当を割り当てます。

以下、次のようなテーブルを前提に記します。

---

1. 加重ラウンドロビン

まずやってみたのが、「加重ラウンドロビン」を使ったロジック。
「東京フレンドパーク」の最後で商品を決めるときの？ロジックですな。

Private Function fPr_担当社員採番( )

    Dim 比率の合計 As Long
    比率の合計 = DSum("担当比率", "tbl_ユーザー")

    Dim rtn As Long
    Randomize
    rtn = Int((比率の合計 - 0 + 1) * Rnd + 0)    ' 0～比率の合計までの乱数を発生
    Set rs = CurrentDb.OpenRecordset("SELECT 担当比率, 社員番号 FROM tbl_ユーザー ORDER BY 担当比率")
    If rs.RecordCount < 1 Then
        MsgBox "社員担当者の情報が未設定です。", vbExclamation + vbOkOnly, "設定エラー"
        fPr_担当社員採番 = ""
        Exit Function
    End If

    Dim 累計 As Long
    累計 = 0
    rs.MoveFirst
    Do While (Not rs.EOF)
        累計 = 累計 + rs![担当比率]       ' 担当比率の小さい順に値を累積
        If rtn <= 累計 Then             ' ⇒担当比率の大きいメンバーほどここの条件にヒットしやすい
            fPb_担当社員採番 = rs![社員番号]
            Exit Function
        Else
            rs.MoveNext
        End If
    Loop
    rs.Close
        
End Function

---

2. ただ・・・

この方法だと乱数に依存するため、短期的に特定のメンバーに付加が集中したり、ときに何連続かで割り当てられてしまいます。
都度処理するので、やはりその時点での割り振り状況は考慮すべきですね・・・

ということで、次のような処理を考えてみました。
①当日以降に割り当てられている案件数を担当者ごとに集計
②①より、各担当の割り当て済み件数の割合を計算
③設定した担当比率と2)の割合との差分が大きい＆前回割り当てが古い順に担当を割り振る

クエリー：q_担当割集計1

-- 後ほどLEFT JOINするので、ここで案件情報を抽出します
SELECT 案件ID, 担当社員番号, 作成年月日
FROM tbl_案件
WHERE 担当社員番号 IS NOT NULL
AND 作業年月日 > Date();

クエリー：q_担当割集計2

-- 社員ごと割り当て済件数と最終割当日を集計
SELECT
    tbl_ユーザー.社員番号,
    tbl_ユーザー.担当比率,
    Count(q_担当割集計1.案件ID) AS 割当済件数,
    Max(q_担当割集計1.作成年月日) AS 直近割当日
FROM
    tbl_ユーザー LEFT JOIN q_担当割集計1
    ON tbl_ユーザー.社員番号 = q_担当割集計1.担当社員番号
GROUP BY
    tbl_ユーザー.社員番号,
    tbl_ユーザー.担当比率

クエリー：q_担当割集計3

SELECT
    社員番号,
    割当済件数,
    Iif(Nz([担当済件数], 0) = 0, 0, [割当済件数] * 100 / DCount("*", "q_担当割集計1") - [担当比率]) As 差分,
    担当比率,
    直近割当日
FROM
    q_担当割集計2
ORDER BY
    Iif(Nz([担当済件数], 0) = 0, 0, [割当済件数] * 100 / DCount("*", "q_担当割集計1") - [担当比率]) As 差分,
    担当比率 DESC,
    直近割当日;

Private Function fPr_担当社員採番()

    Dim rs As DAO.Recordset
    With CurrentDb.QueryDefs("q_担当割集計3")
        Set rs = .OpenRecordset(dbOpenSnapshot)
        .Close
    End With
    If rs.RecordCount < 1 Then
        MsgBox "担当社員の割り当てに失敗しました。", vbExclamation + vbOKOnly, "エラー"
        fPr_担当社員採番 = ""
        Exit Function
    Else
        rs.MoveFirst
        fPr_担当社員採番 = rs![社員番号]
    End If

End Function

幸い、上記のロジックで約２ヶ月ほど無事に稼働しております。