Accessで条件付きグループ分けを作ってみた

企業、学校、個人。それぞれのシーンに於いて一定の需要があるのが「グループ分け」。人の班分けだけでなく、物品のグルーピングなどに於いて一定の条件の元グループ分けをする作業は、人間が行うと高確率で失敗します。

しかし、自分の需要にあったグループ分けプログラムは自分で作るしかありません。そこで今回研修会参加者を一定条件に基づいて班分けするというプログラムを作成しました。

1 今回使用するファイル
2 事前準備と条件
3 使い方
4 ソースコード
- 4.1 グループ分けを実行するコード
- 4.2 実行結果をExcelシートに書き出すコード
5 関連リンク

今回使用するファイル

グループ分けプログラム - Access2016で作成（64bit）
日程表テンプレート - 上記のプログラムにも同梱のexcelシート

※日程表テンプレートに参加者情報を記述して、Access側にインポートする仕組みになっています。グループ分けはAccess側で行わせます。

※2025年6月、Gemini APIを使って同様のプログラムをGoogle Apps Scriptで実現してみました。以下のエントリーを御覧ください。

Google Apps ScriptとGeminiで条件付きグループ分け【GAS】

事前準備と条件

プログラムの準備

このプログラムは以下の参照設定を利用しています。今どきの環境で追加しなければならないというものは無いと思いますので、通常は特に何もする必要はありません（自前で構築する場合を除く）

Microsoft Office 15.0 Object Library - リボンの構築で使用しています。
Microsoft Scripting Runtime - ファイルの有無など様々なシーンで利用しています。
ActiveX Data Object 2.8 Library - Excelデータの書き出し時に今回利用しています。

また、暗号化ZIP形式でのバックアップ・復元の為に、7-zip64.dllを利用しています（ファイルに同梱）。

図：ライブラリの参照が必要

日程表の準備

日程表テンプレートにデータの追記が必要です。本プログラムはこの日程表を取り込んで、グループ分けをするプログラムという形にしているため、事前にデータの準備が必要になります。

データはテーブル形式になっており、今回利用する列は以下の通り。

会社No（数値）
会社名（文字列）
部署（文字列）
業種（文字列）
姓_漢字（文字列）
名_漢字（文字列）
姓_全角カナ（文字列）
名_全角カナ（文字列）
年齢（数値）
性別（文字列） - 男 or 女

各種コードシートは、メインの受講者リストの入力を助けるためのものなので、特に整備はせずとも良いですが、データの入力規則やvlookup関数での参照などで利用すると良いでしょう。

グループ分け条件

今回のプログラムでは振り分ける条件を固定ではなく、いくつかはオプションで選べるように作成しています。固定の条件としては人数チェックと男女比チェックは必ず実行するようにしています（つまり、1チーム指定の人数を超えているか？男女比が約半分になってるかどうか？）。

リボンのグループ分け⇒アプリの設定を開く
アプリの設定ダイアログ内の「アプリの設定」タブを開く
振り分けオプションでさらに振り分け条件を加えたい場合にはチェックを入れる
グループ人数は、1チーム当たりの人数です。日程表参加者をこの数値で割った値がグループの数になります。
年齢構成チェックは、全体の中央値（平均値ではない）に近くなるように、振り分けチーム内の年齢構成を考慮して、チームに加える設定です。
同姓チェックは、同じ姓を持つものはなるべく一緒にしないようにする為の設定です。
同企業チェックは、複数会社参加の振り分けをする際に、同じチーム内に同じ会社の人間を一緒にしない為の設定です。
同業種チェックは、複数会社参加の振り分けをする際に、同じチーム内に同じ業種の人間を一緒にしない為の設定です。
同部署チェックは、同じチーム内に同じ部署の人間が一緒にしない為の設定です。
年齢構成チェックをオンにすると、「なるべく近い歳」というオプションが使えます。このオプションは追加時のチーム内最小年齢の上下2歳までをチームに追加可とするという条件に変更する為のものです。
保存を押すとsettingテーブルにオプション設定が保存されます。

振り分けには乱数を利用し、グループ数分のコードが割り振られるようになっていますが、条件によっては必ずしも条件通りの振り分けができるとは限りません。その場合、あぶれた人は再度、人数チェックと男女比チェックだけでどこかのチームにねじ込むようにプログラムされています。条件にあぶれた人をねじ込んでるので、条件通りになっていないチームも発生します。

但しこれでもあぶれるケースがあります。この場合振り分け失敗となりますが、乱数を使ってるので、再度振り分け実行を行えばうまくいく事もあります。

使い方

使い方自体は非常に単純です。

受講者リストのインポートをクリックし、用意した日程表テンプレートを読み込ませてデータを取り込みます（洗い替えなので、新しいデータを取り込むと古いデータは削除されます）
グループ分け実行を行うと。アプリの設定にてセットした条件に基づいて判定し、チーム割を行います。
グループ分けが完了するとグループ分け結果フォームが表示され、チーム内平均年齢や人数、それぞれの人間の値が表示されます。
グループ分け出力をクリックすると、指定の場所に受講者リストとして分けた結果をソートしたデータをExcel形式で出力してくれます。

ZIPバックアップを活用すると、セットした条件やその時の結果などをキープしておけ、復元で元に戻せるようになっています。いくつか試してみて納得の行くパターンになったら、出力してみると良いでしょう。

ソースコード

グループ分けを実行するコード

'グループ分けを行うメインルーチン
Public Function groupin()
'変数の宣言
Dim alluser As Integer    '全ユーザ数
Dim mbrlimit As Integer   '1チームあたり人数
Dim grpcount As Integer   'グループ数
Dim avgage As Double     '全ユーザ平均年齢
Dim insflg As Boolean     '追加していいよフラグ
Dim i As Long
Dim cnt As Long
mbrlimit = DLookup("値", "setting", "ID=1")    'グループ人数設定を取得
cnt = 1
Dim result As Variant
Dim checkernum As Boolean
Dim empid As Integer
Dim danjolim As Integer
Dim seibetsu As String
Dim breaker As Integer
breaker = 1
Dim targetage As Integer
Dim firstname As String
Dim compid As Integer
Dim nejiko As Integer
Dim gyouname As String
Dim busyoname As String
nejiko = 0
Dim ans As Integer
'該当レコードが処理済みになってる場合問い合わせをする
result = MsgBox("取り込んだリストを元にグループ分けを実行しますか？", vbYesNo + vbDefaultButton2 + vbExclamation)
If result = vbYes Then
'インポート処理を続行する
Else
'メッセージを表示
MsgBox "データの更新をキャンセルしました。"
'終了処理
Exit Function
End If
'DB接続用変数
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim rse As DAO.Recordset
Dim rso As DAO.Recordset
Dim strSQL As Variant
Set db = CurrentDb
'テーブルデータをクリアする
strSQL = "DELETE * FROM グループ"
db.Execute strSQL
strSQL = "DELETE * FROM チーム"
db.Execute strSQL
'レコードセットをセットする
Set rst = db.OpenRecordset("受講者リストソート")
Set rse = db.OpenRecordset("グループ")
Set rso = db.OpenRecordset("チーム")
'グループ数と平均年齢を取得する
alluser = DCount("ID", "受講者リスト")
grpcount = RoundUp(alluser / mbrlimit, 0)  '小数点以下桁上げ
avgage = CInt(DLookup("Median", "中央値"))      '全平均年齢
danjolim = RoundUp(mbrlimit / 2, 0)
'グループテーブルに連番でグループを生成
For i = 1 To grpcount
With rse
.AddNew
!グループナンバー = cnt
.Update
End With
'カウンタを回す
cnt = cnt + 1
Next i
'条件判定して受講者IDをチームテーブルに追加する
Dim teamavg As Variant
Dim options As Variant
Dim beforeflg As Integer
Dim tempavgage As Integer
beforeflg = 0
'振り分けオプションの取得
Dim nencheck As Variant
Dim doucheck As Variant
Dim comcheck As Variant
Dim induscheck As Variant
Dim bucheck As Variant
Dim naruage As Variant
nencheck = DLookup("値", "setting", "ID=2")
doucheck = DLookup("値", "setting", "ID=3")
comcheck = DLookup("値", "setting", "ID=4")
induscheck = DLookup("値", "setting", "ID=5")
bucheck = DLookup("値", "setting", "ID=6")
naruage = DLookup("値", "setting", "ID=7")
Do Until rst.EOF
'カウンタ・フラグ初期化
breaker = 1
insflg = False
'受講者IDを取得する
empid = rst("ID")
'性別を取得する
seibetsu = rst("性別")
seibetsu = Replace(seibetsu, "性", "")
'年齢を取得する
targetage = rst("年齢")
'名字を取得する
firstname = rst("姓_漢字")
'会社Noを取得する
compid = rst("会社No")
'業種名を取得する
gyouname = rst("業種")
'部署名を取得する
If IsNull(rst("部署")) Then
busyoname = ""
Else
busyoname = rst("部署")
End If
'乱数初期化
Randomize
Do Until insflg = True
'変数初期化
beforeflg = 0
'ランダムなcntを生成
cnt = Int(grpcount * Rnd + 1)
'カウンタが既定値を超えていた場合にはプログラムを終了する（無限ループ防止）
If breaker > grpcount Then
Exit Do
End If
'人数がリミットに達していなければtrue
checkernum = checkman(mbrlimit, cnt)
If checkernum = True Then
'男女比的にNGかどうか？
checkernum = danjocheck(danjolim, cnt, seibetsu)
If checkernum = True Then
'年齢チェック開始
options = nencheck
If options = -1 Then
'なるべく近い歳オプションの有無
options = naruage
If options = -1 Then
'チームの最小年齢を算出
teamavg = DMin("年齢", "チーム", "グループナンバー=" & cnt)
If IsNull(teamavg) Then
'フラグを立てる
beforeflg = beforeflg + 1
Else
'最小年齢の前後2歳までを対象とする
tempavgage = targetage - teamavg
'マイナス値の場合はプラス値に変える
If tempavgage < 0 Then
tempavgage = tempavgage * -1
End If
If tempavgage > 2 Then
'年齢を2歳超えてるのでNG
Else
'OKなのでフラグを立てる
beforeflg = beforeflg + 1
End If
End If
Else
'従来の平均年齢に沿った振り分けを実行
'対象のチームの平均年齢を出す
teamavg = DAvg("年齢", "チーム", "グループナンバー=" & cnt)
If IsNull(teamavg) Then
teamavg = 0
End If
'年齢が対象となるものかどうか判定
checkernum = agecheck(avgage, CDbl(teamavg), targetage)
If checkernum = True Then
beforeflg = beforeflg + 1
End If
End If
Else
beforeflg = beforeflg + 1
End If
'同部署チェック開始
options = bucheck
If options = -1 Then
'年齢が対象となるものかどうか判定
checkernum = bumoncheck(busyoname, cnt)
If checkernum = True Then
beforeflg = beforeflg + 1
End If
Else
beforeflg = beforeflg + 1
End If
'同企業チェック開始
options = comcheck
If options = -1 Then
checkernum = compcheck(compid, cnt)
If checkernum = True Then
beforeflg = beforeflg + 1
End If
Else
beforeflg = beforeflg + 1
End If
'同業種チェック開始
options = induscheck
If options = -1 Then
checkernum = gyoucheck(gyouname, cnt)
If checkernum = True Then
beforeflg = beforeflg + 1
End If
Else
beforeflg = beforeflg + 1
End If
'同姓チェック開始
options = doucheck
If options = -1 Then
checkernum = firstcheck(firstname, cnt)
If checkernum = True Then
beforeflg = beforeflg + 1
End If
Else
beforeflg = beforeflg + 1
End If
'beforeflgの値が5ならば追加する
If beforeflg = 5 Then
'チームにメンバーを追加する
With rso
.AddNew
!グループナンバー = cnt
!受講者ID = empid
!性別 = seibetsu
!年齢 = targetage
!姓_漢字 = firstname
!会社No = compid
!業種 = gyouname
!部署 = busyoname
.Update
End With
'フラグを立てる
insflg = True
End If
End If
End If
'breakerカウントをアップ
breaker = breaker + 1
Loop
'この時点でinsflgがfalseの場合どこかのチームにねじ込む（ファジー対応）
If insflg = False Then
'ねじこみカウント追加
nejiko = nejiko + 1
'変数初期化
breaker = 1
'乱数初期化
Randomize
Do Until insflg = True
'ランダムなcntを生成
cnt = Int(grpcount * Rnd + 1)
'カウンタが既定値を超えていた場合にはプログラムを終了する（無限ループ防止）
If breaker > grpcount Then
Exit Do
End If
'人数がリミットに達しているかチェック
checkernum = checkman(mbrlimit, cnt)
If checkernum = True Then
'男女比的にNGかどうか？チェック
checkernum = danjocheck(danjolim, cnt, seibetsu)
If checkernum = True Then
'チームにメンバーをねじこむ
With rso
.AddNew
!グループナンバー = cnt
!受講者ID = empid
!性別 = seibetsu
!年齢 = targetage
!姓_漢字 = firstname
!会社No = compid
!業種 = gyouname
!部署 = busyoname
.Update
End With
'フラグを立てる
insflg = True
End If
End If
'breakerをカウントアップ
breaker = breaker + 1
Loop
'最終チェック
If insflg = False Then
ans = MsgBox("条件厳しくて、だめだったっぽい。。", vbOKOnly + vbCritical, "失敗！！")
Exit Function
End If
End If
'次のレコードへ移動する
rst.MoveNext
Loop
'ねじ込みカウント表示
If nejiko = 0 Then
Else
ans = MsgBox(nejiko & "件ねじこみました。", vbOKOnly + vbInformation, "ネジ込み件数")
End If
'終了処理
ans = MsgBox("チーム分けが完了しました", vbOKOnly + vbInformation, "処理完了")
DoCmd.OpenForm "グループ分け結果", acNormal, , , acFormEdit, acWindowNormal
rst.Close
rse.Close
rso.Close
Set rso = Nothing
Set rse = Nothing
Set rst = Nothing
Set db = Nothing
End Function
'人数チェックをする関数
Public Function checkman(ByVal limit As Integer, ByVal teamnum As Integer) As Boolean
'対象のteamnumの現在の枠数をチェック
Dim check As Variant
check = DLookup("受講者IDのカウント", "人数カウント", "グループナンバー=" & teamnum)
'メンバー数がリミットに達しているかどうか
If check >= limit Then
checkman = False
Else
checkman = True
End If
End Function
'男女比をチェックする関数
Public Function danjocheck(ByVal limit As Integer, ByVal teamnum As Integer, ByVal sei As String) As Boolean
'対象のteamnumの現在のhanseiの値がlimitに達しているかチェック
Dim check As Variant
check = DCount("ID", "チーム", "性別='" & sei & "' AND グループナンバー=" & teamnum)
If check > limit - 1 Then
'リミット超えてるので追加だめ
danjocheck = False
Else
'リミット達していないのでOK
danjocheck = True
End If
End Function
'年齢平均チェックをする関数
Public Function agecheck(ByVal allavg As Double, ByVal teamavg As Double, ByVal targetage As Integer) As Boolean
'変数の宣言
Dim hantei As Boolean
'全平均とチーム平均の比較
If allavg >= teamavg Then
'ターゲットとチーム平均を比較（高い方を入れる）
If targetage >= teamavg Then
hantei = True
Else
hantei = False
End If
Else
'ターゲットとチーム平均の比較（低い方を入れる）
If targetage >= teamavg Then
hantei = False
Else
hantei = True
End If
End If
'判定結果を返す
agecheck = hantei
End Function
'同じ姓の人間がいるかどうかチェックする関数
Public Function firstcheck(ByVal firstname As String, ByVal teamnum As Integer) As Boolean
'対象のteamnumに於いて、同姓の人間が何名いるか？
Dim check As Variant
check = DCount("ID", "チーム", "姓_漢字='" & firstname & "' AND グループナンバー=" & teamnum)
'カウントが0ならばtrue
If check = 0 Then
firstcheck = True
Else
firstcheck = False
End If
End Function
'会社名の重複があるかどうかチェックする関数
Public Function compcheck(ByVal compid As Integer, ByVal teamnum As Integer) As Boolean
'対象のteamnumの現在のhanseiの値がlimitに達しているかチェック
Dim check As Variant
check = DCount("ID", "チーム", "会社No=" & compid & " AND グループナンバー=" & teamnum)
'カウントが0ならばtrue
If check = 0 Then
compcheck = True
Else
compcheck = False
End If
End Function
'同じ業種の重複があるかどうかをチェックする関数
Public Function gyoucheck(ByVal gyouname As String, ByVal teamnum As Integer) As Boolean
'対象のteamnumに指定のgyounameが含まれている件数をチェック
Dim check As Variant
check = DCount("ID", "チーム", "業種='" & gyouname & "' AND グループナンバー=" & teamnum)
'カウントが0ならばtrue
If check = 0 Then
gyoucheck = True
Else
cgyoucheck = False
End If
End Function
'部署名の重複があるかどうかをチェックする関数
Public Function bumoncheck(ByVal buname As String, ByVal teamnum As Integer) As Boolean
'対象のteamnumに指定のgyounameが含まれている件数をチェック
Dim check As Variant
check = DCount("ID", "チーム", "部署='" & buname & "' AND グループナンバー=" & teamnum)
'カウントが0ならばtrue
If check = 0 Then
bumoncheck = True
Else
bumoncheck = False
End If
End Function

グループテーブルは振り分け後の振り分け結果の親テーブルです。チームテーブルがそれにぶら下がるサブテーブルとなります。
受講者リストソートはクエリです。人数が多い順に会社毎にソートしています（こうする事で振り分け成功率が上がります）
グループ数は参加者総数÷1チーム当たり人数で算出。
平均年齢とありますが、実際には中央値を利用しています。振り分け時に、全体中央値よりチーム平均値が低い場合、高い場合、それぞれに於いて追加しようとしてる者の年齢を比較して追加するか？しないかを決定しています。
男女比の算出は全体から算出。1チーム当たり人数÷2で計算していますが、男女比が1:1ではないようなケースでは、ここの加工が必要になります。
対象者の追加可否のトライ回数はグループ数回分行う。この判定用にbreaker変数を用意してあり、breakerがリミットに達したら、ループを強制離脱します。
チェック順序はより条件が厳しい重複可能性の高い項目から行っています（でないと、条件適合外が大量に発生してしまう）。
順番は、人数リミットチェック、男女比チェック、部署チェック、同部署チェック、同企業チェック、同業種チェック、同姓チェックの順に行っています。
beforeflgに値を加算する事で通過とし、合計値がオプション項目の数の合計である5に達したらチームに加えるようにしています。
あぶれた場合、2段階目として「人数リミット」「男女比」のチェックのみで通過とし、チームに強制振り分けをさせています。
それでもNGの場合には「失敗」と看做し、プログラムは強制終了します。但し、Rnd関数によるランダムな生成なので、再度の実行や条件の緩和によって通過するようになるかもしれません。

実行結果をExcelシートに書き出すコード

'振り分け結果データをExcel Automationで出力する
Public Function exportReport()
Dim AppObj As Object 'Excel.Applicationオブジェクトの宣言
Dim WBObj As Object 'Excel.Workbookオブジェクトの宣言
Dim WsObj As Object 'Excel.WorkSheetオブジェクトの宣言
Dim WsObj2 As Object
Dim FilePath As String
Dim strFileName As Variant
Dim dummyfile As String
’DB接続用の変数
Dim dbs As Database
Dim strSQL As String
Set dbs = CurrentDb
'コネクションを確立する
Dim con As New ADODB.Connection
Dim rec As New ADODB.Recordset
Set con = CurrentProject.Connection
'デスクトップフォルダを取得
Dim dPath As String, WSH As Variant
Set WSH = CreateObject("WScript.Shell")
dPath = WSH.SpecialFolders("Desktop") & "\"
'仮のファイル名を生成する
dummyfile = dPath & "受講者管理シート"
'名前をつけて保存ダイアログを表示
strFileName = GetFileName(False, 'MicrosoftExcel ブック (*.xlsx)|*.xlsx', '', dummyfile & '.xlsx')
'選択結果を評価
If strFileName = 0 Then
'キャンセルボタンが押されたときの処理を記述
MsgBox "キャンセルされました。"
Exit Function
End If
'テンプレファイルを指定する
FilePath = CurrentProject.Path & "\export.xlsx"
'ファイルを複製する（ダイアログ使用）
FileCopy FilePath, strFileName
'ファイルを開く
Set AppObj = CreateObject("Excel.Application") '実行時バインディング
Set WBObj = AppObj.Workbooks.Open(strFileName) 'ワークブックを開く
Set WsObj = WBObj.Worksheets("事務局用会社順")
'excel画面の更新をオフにする
AppObj.ScreenUpdating = False
'砂時計のマウスポインタ
DoCmd.Hourglass True
AppObj.Visible = True 'Excelアプリケーションを表示する
AppObj.Calculation = xlManual '再計算を停止する
'ワークシートへの処理
'Excelにエクスポートしたいテーブルのデータを取得
rec.Open "事務局用会社順", con
WsObj.Range("a2").CopyFromRecordset rec
rec.Close
Set WsObj = WBObj.Worksheets("事務局用50音順")
rec.Open "事務局用50音順", con
WsObj.Range("a2").CopyFromRecordset rec
rec.Close
Set WsObj = WBObj.Worksheets("事務局用G順")
rec.Open "事務局用G順", con
WsObj.Range("a2").CopyFromRecordset rec
rec.Close
Set WsObj = WBObj.Worksheets("受講者用G順")
rec.Open "受講者用G順", con
WsObj.Range("a2").CopyFromRecordset rec
rec.Close
'再計算に戻す
AppObj.Calculation = xlAutomatic
AppObj.ScreenUpdating = True
'砂時計のマウスポインタ
DoCmd.Hourglass False
'Excelを保存して閉じる
WBObj.Save 'ワークブックを保存する
WBObj.Close 'ワークブックを閉じる
AppObj.Quit
'終了処理
Set AppObj = Nothing
Set WBObj = Nothing
Set WsObj = Nothing
Set WsObj2 = Nothing
'メッセージ表示
MsgBox "受講者管理シートデータの作成が完了しました。"
End Function
Function GetFileName(OpenOrSaveFlg As Boolean, strFilter As String, _
strTitle As String, strDefaultPath As String) As String
Dim returnValue As Integer
Dim strFilePath As String
strFilePath = strDefaultPath
If strFilter = "" Then
strFilter = "全てのファイル (*.*)|*.*"
End If
WizHook.key = 51488399 'WIZHOOK有効
returnValue = WizHook.GetFileName( _
0, "", strTitle, "", strFilePath, "", _
strFilter, _
0, 0, 0, OpenOrSaveFlg _
)
WizHook.key = 0 ' WizHook 無効
If returnValue = 0 Then
GetFileName = strFilePath
Else
GetFileName = 0
End If
End Function
'全角半角カナ変換
Public Function kanahen(kanaword As String) As String
kanahen = StrConv(kanaword, vbWide)
End Function
'へんなスペース除去
Public Function cutspace(words As String) As String
Dim temp As String
'全角半角のスペース除去
temp = Replace(words, " ", "")
temp = Replace(words, "　", "")
cutspace = temp
End Function

デスクトップフォルダを初期値として、export.xlsxファイルをコピーし、そこに出力します。
チーム内容をソートしたクエリをそれぞれ、CopyFromRecordsetメソッドで指定のシートに出力します。
GetFileName関数はファイルの選択用ダイアログを出すための関数です。
時々指定の列の文字に半角全角混在してるケースがあるので、kanahenにて全角カナに統一しています。
時々指定の列の文字にスペースが混在してるケースがあるので、cutspaceにてスペースは除去しています。
ADOとCopyFromRecordsetがあれば同様のデータ出力は可能なので、Excel単体でも出力系は完結は可能といえば可能です。

Accessで条件付きグループ分けを作ってみた

今回使用するファイル