グループ分けツール

大人数を自動でグループ分けするコードを書きました。
「性別」「所属」などの要素を与えれば、グループ内でなるべくこれらの要素が被らないようにグループ分けをします。

以下のような仕組みになっています。
1. 要素でソートし、上から順番に暫定グループを割り振る。
2. グループの多様性（Shannon entropy）を計算する。
3. 多様性が改善されなくなるまで、グループ間で人をスワップする。

下準備

• 「使い方」「入力データ」「出力結果」というシートを用意する。
• 入力データにグループ分けしたい人の一覧を入力する。1行目はヘッダー。1列目は氏名、2列目以降からグループ分けに使う要素（要素数は何個でもOK）。

コード

Sub SeparateIntoGroups()

    '####################### 初期化 #######################
    
    ' 変数定義
    Dim LastRow As Long
    Dim LastCol As Long
    Dim i As Long, j As Long
    Dim wsIntro As Worksheet
    Dim wsInput As Worksheet
    Dim wsOutput As Worksheet
    Dim GroupsCount As Long
    Dim GroupNumber As Long
    Dim dataArray() As Variant
    
    ' 高速化設定
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False

    ' ワークシートの取得
    Set wsIntro = ThisWorkbook.Sheets("使い方")
    Set wsInput = ThisWorkbook.Sheets("入力データ")
    Set wsOutput = ThisWorkbook.Sheets("出力結果")

    ' 元データの最終行と最終列の取得
    LastRow = wsInput.Cells(wsInput.Rows.Count, "A").End(xlUp).Row
    LastCol = wsInput.Cells(1, wsInput.Columns.Count).End(xlToLeft).Column

    ' グループ数の取得
    GroupsCount = wsIntro.Cells(13, 2).Value
    
    
    '####################### 一覧コピー #######################

    ' 「出力結果」シートにコピーする
    wsInput.Range(wsInput.Cells(1, 1), wsInput.Cells(LastRow, LastCol)).Copy
    wsOutput.Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False

    ' グループ列を作成する
    wsOutput.Cells(1, LastCol + 1).Value = "グループ"


    '####################### ソートして暫定グループを決定 #######################

    ' ユーザーの属性でソートする
    Call SortBasedOnAttributes(wsOutput, LastRow, LastCol)

    ' グループ列を作成して暫定グループを入力する
    For i = 2 To LastRow
        GroupNumber = (i - 2) Mod GroupsCount + 1
        wsOutput.Cells(i, LastCol + 1).Value = GroupNumber
    Next i

    ' グループでソートする
    Call SortBasedOnAttributes(wsOutput, LastRow, LastCol + 1, True)

    
    '####################### MDGP(Maxmimally Diverse Grouping Problem)で最適化する #######################
    
    '　「出力結果」シートを配列に格納する
    ReDim dataArray(1 To LastRow, 1 To LastCol + 1)
    For i = 1 To LastRow
        For j = 1 To LastCol + 1
            dataArray(i, j) = wsOutput.Cells(i, j).Value
        Next j
    Next i
    
    ' グループの多様性を向上させる
    Dim diversityScore As Double
    dataArray = SwapUntilNoImprovement(dataArray, GroupsCount)


    wsOutput.Range("A1").Resize(LastRow, LastCol + 1) = dataArray
    
    
    '####################### 終了処理 #######################
    
    ' 高速化設定の無効化
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub






'###################################################################################################################
'#################################################【関数】##########################################################
'###################################################################################################################


' 他項目ソート（左列が優先度高、一番右の列でのみソートする場合はSortLastColumnOnly=Trueにする）
Function SortBasedOnAttributes(ByRef ws As Worksheet, ByVal LastRow As Long, ByVal LastCol As Long, Optional SortLastColumnOnly As Boolean = False)

    ' 変数定義
    Dim SortFields As Range, i As Long
    Dim SortKeys As Object
    Dim StartCol As Long

    ' 開始列設定
    If SortLastColumnOnly Then
        StartCol = LastCol
    Else
        StartCol = 2
    End If
    
    ' ソート
    With ws.Sort
        .SortFields.Clear
        For i = StartCol To LastCol
            .SortFields.Add key:=Range(Cells(2, i), Cells(LastRow, i)), _
                            SortOn:=xlSortOnValues, _
                            Order:=xlAscending, _
                            DataOption:=xlSortNormal
        Next i
        .SetRange Range(Cells(2, 1), Cells(LastRow, LastCol))
        .Header = xlNo
        .Apply
    End With
    
End Function


' グループの多様性を数値化（Shannon entropy）
Function ComputeGroupDiversityScore(arr() As Variant, GroupsCount As Long) As Double
    
    ' 変数定義
    Dim StartRow As Long, EndRow As Long, r As Long
    Dim UniqueVals As Object
    Dim g As Long, i As Long, j As Long
    Dim total As Long
    Dim proportion As Double
    Dim entropy As Double
    Dim attributeDiversity() As Double
    Dim minVal As Double, maxVal As Double
    Dim LastCol As Long
    
    ' 最終列の取得
    LastCol = UBound(arr, 2)
    
    ' 多様性スコア配列初期化
    ReDim attributeDiversity(1 To GroupsCount, 2 To LastCol - 1)
    
    ' 一意の値カウンタ初期化
    Set UniqueVals = CreateObject("Scripting.Dictionary")

    ' 各グループで繰り返す
    For g = 1 To GroupsCount
    
        ' グループの開始列と終了列を取得
        StartRow = Application.Match(g, Application.Index(arr, 0, LastCol), 0)
        EndRow = Application.Match(g, Application.Index(arr, 0, LastCol), 1)
        total = EndRow - StartRow + 1
    
        ' 要素で繰り返す
        For j = 2 To LastCol - 1
            
            ' 一意の値と頻度を取得
            For r = StartRow To EndRow
                If Not UniqueVals.Exists(arr(r, j)) Then
                    UniqueVals.Add arr(r, j), 1
                Else
                    UniqueVals(arr(r, j)) = UniqueVals(arr(r, j)) + 1
                End If
            Next r
            
            ' Shannon entropyを計算（男3女1より男2女2の方がスコアが高くなる）
            For Each key In UniqueVals.Keys
                proportion = UniqueVals(key) / total
                If proportion > 0 Then
                    entropy = entropy - (proportion * Log(proportion) / Log(2))
                End If
            Next key
            
            ' 記録して初期化
            attributeDiversity(g, j) = entropy
            UniqueVals.RemoveAll
            entropy = 0
            
        Next j
    Next g
    
    ' 多様性スコアを要素ごとに正規化する（最小0, 最大1)
    For j = 2 To LastCol - 1
        ' 最小値、最大値取得
        minVal = 0
        maxVal = attributeDiversity(1, j)
        For i = 2 To GroupsCount
            If attributeDiversity(i, j) > maxVal Then maxVal = attributeDiversity(i, j)
        Next i
        If maxVal = minVal Then
            ' 全グループのスコアが0であれば1にする
            For i = 1 To GroupsCount
                attributeDiversity(i, j) = 1
            Next i
        Else
            ' 正規化する
            For i = 1 To GroupsCount
                attributeDiversity(i, j) = (attributeDiversity(i, j) - minVal) / (maxVal - minVal)
            Next i
        End If
    Next j
    
    ' 多様性スコアを全て足す
    For j = 2 To LastCol - 1
        For i = 1 To GroupsCount
            entropy = entropy + attributeDiversity(i, j)
        Next i
    Next j
    
    Debug.Print (entropy)
    ComputeGroupDiversityScore = entropy
End Function


' グループの多様性が向上しなくなるまでスワッピング
Function SwapUntilNoImprovement(arr() As Variant, GroupsCount As Long) As Variant

    ' 変数定義
    Dim Improved As Boolean
    Dim i As Long, j As Long
    Dim r1 As Long, r2 As Long
    Dim UserCount As Long, LastRow As Long, LastCol As Long
    Dim SwappedArray() As Variant
    Dim CurrentScore As Double, SwappedScore As Double
    
    ' 最終行、最終列の取得
    UserCount = UBound(arr, 1) - 1
    LastRow = UBound(arr, 1)
    LastCol = UBound(arr, 2)
    ReDim SwappedArray(1 To LastRow, 1 To LastCol)
    
    ' 多様性が改善しなくなるまで繰り返し
    Do
        Improved = False
        CurrentScore = ComputeGroupDiversityScore(arr, GroupsCount)
        
        ' スワップ元は上から順番に
        For r1 = 2 To LastRow - 1
            
            ' スワップ先はスワップ元の1個下から順番に
            For r2 = r1 + 1 To LastRow
                If arr(r1, LastCol) <> arr(r2, LastCol) Then
                    
                    ' 配列をコピー
                    For i = 1 To LastRow
                        For j = 1 To LastCol
                            SwappedArray(i, j) = arr(i, j)
                        Next j
                    Next i
                    
                    ' スワップ
                    For j = 1 To LastCol - 1
                        SwappedArray(r2, j) = arr(r1, j)
                        SwappedArray(r1, j) = arr(r2, j)
                    Next j
                    
                    ' スワップ後の多様性スコア取得し、改善していたら配列更新
                    SwappedScore = ComputeGroupDiversityScore(SwappedArray, GroupsCount)
                    If SwappedScore > CurrentScore Then
                        Improved = True
                        arr = SwappedArray
                        Exit For
                    End If
                    
                End If
            Next r2
            If Improved Then Exit For
        Next r1
        
    Loop Until Not Improved

    SwapUntilNoImprovement = arr
End Function