和風スパゲティのレシピ

日本語でコーディングするExcelVBA

トップ > 100本ノック > 99本目：行列前後左右が違うように自動席替え

99本目：行列前後左右が違うように自動席替え

100本ノック VBA

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：自動席替え（行列と前後左右が全て違うように）

「座席表（現）」を「座席表（新）」へ自動で席替えをしてください。
席替えルールは98本目と同じ。
・全員が違う行列に移動
・前後左右は前回と違う人
※98本目を使い正しく配置できているか確認してください。

ノック99本目：行列前後左右が違うように自動席替え

◇ 出題ページはこちら
excel-ubara.com

ソースコード

モジュール一覧

Df_共通定義

' 座席シートレイアウト
Public Const RCount座席 = 6
Public Const CCount座席 = 6

Function Area現座席() As Range
    Set Area現座席 = WS現座席.Range("B5:G10")
End Function
Function Area新座席() As Range
    Set Area新座席 = WS新座席.Range("B5:G10")
End Function

Op_実行モジュール

Option Explicit

' VBA100本ノック_099_行列前後左右が違うように自動席替え

Sub ★行列前後左右が異なる新座席案を表示する()
    
    Dim Arr新座席: Arr新座席 = Area現座席.Value
    
    ' 行・列をルールを守って並び換え
    Arr新座席 = GetArr各行がすべて別行になりかつ前後同順が出現しないようランダムに並び替える(Arr新座席)
    Arr新座席 = GetArr各列がすべて別列になりかつ左右同順が出現しないようランダムに並び替える(Arr新座席)
    
    ' 完成した配列をルールを守った上でランダムにシャッフル
    Arr新座席 = GetArrルールを守った席交換をn回実施する(Arr新座席, 300)
    
    ' シートに出力
    Area新座席.Value = Arr新座席
    
    ' 完成した新座席をチェック
    If Isすべての並び換えルールを満たす() = False Then
        MsgBox "自動並び換えでルールに合致しない並び換えが発生しました。" & vbLf _
             & "このままファイルを保存してマクロ製作者へ連絡してください。"
    Else
        MsgBox "新座席案を表示しました。"
    End If
    
End Sub

Pr1_条件を満たす行列の並び替え

Option Explicit

Private Const isDebugモード = False

' 行の並び替え
Function GetArr各行がすべて別行になりかつ前後同順が出現しないようランダムに並び替える(Arr座席 As Variant) As Variant
    
    Dim ResArr As Variant
    ReDim ResArr(1 To 6, 1 To 6)
    
    Dim Arr並び替え先R
    Arr並び替え先R = GetArr行列並び替え先

    Dim R As Long, C As Long
    For R = 1 To 6
        For C = 1 To 6
            ResArr(Arr並び替え先R(R), C) = Arr座席(R, C)
        Next
    Next
    
    GetArr各行がすべて別行になりかつ前後同順が出現しないようランダムに並び替える = ResArr
        
    ' デバッグ用
    If isDebugモード Then Call 配列を新規シートに出力する(ResArr)
        
End Function

' 列の並び替え
Function GetArr各列がすべて別列になりかつ左右同順が出現しないようランダムに並び替える(Arr座席 As Variant) As Variant
    
    Dim ResArr As Variant
    ReDim ResArr(1 To 6, 1 To 6)
    
    Dim Arr並び替え先C
    Arr並び替え先C = GetArr行列並び替え先

    Dim R As Long, C As Long
    For R = 1 To 6
        For C = 1 To 6
            ResArr(R, Arr並び替え先C(C)) = Arr座席(R, C)
        Next
    Next
    
    GetArr各列がすべて別列になりかつ左右同順が出現しないようランダムに並び替える = ResArr
        
    ' デバッグ用
    If isDebugモード Then Call 配列を新規シートに出力する(ResArr)
        
End Function

' シート関数を利用して並び順を計算
Function GetArr行列並び替え先()
    With WS並び順生成
        Do
            .Calculate
            If .Range("I1") = True Then
                GetArr行列並び替え先 = GetArrayセルのリストを1次元配列に変換する(.Range("C2:C7"))
                Exit Do
            End If
        Loop
    End With
End Function

Pr2_条件保持ランダムシャッフル

Option Explicit

' 席交換を指定回数実行
Function GetArrルールを守った席交換をn回実施する(Arr座席 As Variant, n As Long)
    Dim ResArr: ResArr = Arr座席
    
    Dim i As Long
    For i = 1 To n
        Call ルール内で交換できるランダムに選んだ2名の席を交換する(ResArr)
    Next
    
    GetArrルールを守った席交換をn回実施する = ResArr
    
End Function

' ランダムに2名の席を交換
Sub ルール内で交換できるランダムに選んだ2名の席を交換する(ByRef Arr座席)

    ' 前後左右判定用のDictionaryを用意
    Dim Dic現座席全ペアリスト As Dictionary
    Set Dic現座席全ペアリスト = CreateDic前後左右全ペアリスト(Area現座席.Value)

    ' 交換が実施できるまで繰り返す
    Do
    
        ' 交換対象の2名を選出
        Dim R1 As Long, R2 As Long, C1 As Long, C2 As Long
        Do
            R1 = Fx.RandBetween(1, RCount座席)
            R2 = Fx.RandBetween(1, RCount座席)
            C1 = Fx.RandBetween(1, CCount座席)
            C2 = Fx.RandBetween(1, CCount座席)
            If R1 <> R2 Or C1 <> C2 Then Exit Do
        Loop
        
        Dim 対象者1 As String: 対象者1 = Arr座席(R1, C1)
        Dim 対象者2 As String: 対象者2 = Arr座席(R2, C2)
    
        ' 行・列が前回と同じにならないかチェック
        If Match列番号(対象者1, Area現座席.Rows(R2)) > 0 Then GoTo 次の交換対象へ
        If Match列番号(対象者2, Area現座席.Rows(R1)) > 0 Then GoTo 次の交換対象へ
        If Match行番号(対象者1, Area現座席.Columns(C2)) > 0 Then GoTo 次の交換対象へ
        If Match行番号(対象者2, Area現座席.Columns(C1)) > 0 Then GoTo 次の交換対象へ
        
        ' 交換後の前後左右に現座席のペアが存在しないかチェック
        If R2 >= 2 Then::::::::::::: If Dic現座席全ペアリスト.Exists(対象者1 & "-" & Arr座席(R2 - 1, C2 + 0)) Then GoTo 次の交換対象へ
        If R2 <= RCount座席 - 1 Then If Dic現座席全ペアリスト.Exists(対象者1 & "-" & Arr座席(R2 + 1, C2 + 0)) Then GoTo 次の交換対象へ
        If C2 >= 2 Then::::::::::::: If Dic現座席全ペアリスト.Exists(対象者1 & "-" & Arr座席(R2 + 0, C2 - 1)) Then GoTo 次の交換対象へ
        If C2 <= CCount座席 - 1 Then If Dic現座席全ペアリスト.Exists(対象者1 & "-" & Arr座席(R2 + 0, C2 + 1)) Then GoTo 次の交換対象へ
    
        If R1 >= 2 Then::::::::::::: If Dic現座席全ペアリスト.Exists(対象者2 & "-" & Arr座席(R1 - 1, C1 + 0)) Then GoTo 次の交換対象へ
        If R1 <= RCount座席 - 1 Then If Dic現座席全ペアリスト.Exists(対象者2 & "-" & Arr座席(R1 + 1, C1 + 0)) Then GoTo 次の交換対象へ
        If C1 >= 2 Then::::::::::::: If Dic現座席全ペアリスト.Exists(対象者2 & "-" & Arr座席(R1 + 0, C1 - 1)) Then GoTo 次の交換対象へ
        If C1 <= CCount座席 - 1 Then If Dic現座席全ペアリスト.Exists(対象者2 & "-" & Arr座席(R1 + 0, C1 + 1)) Then GoTo 次の交換対象へ
    
        ' 全チェックを突破したらすり替えを実施
        Arr座席(R1, C1) = 対象者2
        Arr座席(R2, C2) = 対象者1
        Exit Do
        

次の交換対象へ:
    Loop
    
End Sub

' テストメソッド
Private Sub ランダムシャッフルテスト()

    Dim Arr新座席: Arr新座席 = Area現座席.Value
    Arr新座席 = GetArr各行がすべて別行になりかつ前後同順が出現しないようランダムに並び替える(Arr新座席)
    Arr新座席 = GetArr各列がすべて別列になりかつ左右同順が出現しないようランダムに並び替える(Arr新座席)
    Area新座席.Value = Arr新座席
    
    Dim Arr座席: Arr座席 = Area新座席.Value
    Dim Arr実行前の座席
    Dim i As Long
    For i = 1 To 100
        Arr実行前の座席 = Arr座席
        Call ルール内で交換できるランダムに選んだ2名の席を交換する(Arr座席)
        Area新座席.Value = Arr座席
        If Isすべての並び換えルールを満たす = False Then
            Call 配列を新規シートに出力する(Arr実行前の座席)
            Call Err.Raise(1000, , "エラー検知")
        End If
    Next
    
    MsgBox "テスト完了"

End Sub

Ts_新座席の条件合致チェック

Option Explicit

' VBA100本ノック_098_席替えルールが守られているか確認

Private Const isDebugモード = False

Private Enum Color警告
    同行 = rgbGold
    同列 = rgbOrange
    前後左右 = rgbTomato
End Enum

' 実行プロシージャ
Sub ★新座席の並び替えルールをチェックして違反セルを着色する()

    Call ★新座席の着色をクリアする

    ' 各ルールをそれぞれチェック
    Dim isひとつでも違反がある As Boolean
    isひとつでも違反がある = Is現座席と新座席が同じ行の生徒を着色する Or isひとつでも違反がある
    isひとつでも違反がある = Is現座席と新座席が同じ列の生徒を着色する Or isひとつでも違反がある
    isひとつでも違反がある = Is前後左右が現座席に存在する新座席のペアを着色する Or isひとつでも違反がある

    If isひとつでも違反がある Then
        MsgBox "ルール違反を検知したため該当セルを着色しました。"
    Else
        MsgBox "新座席は並び替えルールを満たしています。"
    End If

End Sub

' 行のチェック
Function Is現座席と新座席が同じ行の生徒を着色する() As Boolean
    Dim R As Long, C As Long
    For R = 1 To RCount座席
        For C = 1 To CCount座席
            If Match列番号(Area新座席.Cells(R, C), Area現座席.Rows(R)) > 0 Then
                Area新座席.Cells(R, C).Interior.Color = Color警告.同行
                Is現座席と新座席が同じ行の生徒を着色する = True
            End If
        Next
    Next
End Function

' 列のチェック
Function Is現座席と新座席が同じ列の生徒を着色する() As Boolean
    Dim R As Long, C As Long
    For C = 1 To CCount座席
        For R = 1 To RCount座席
            If Match行番号(Area新座席.Cells(R, C), Area現座席.Columns(C)) > 0 Then
                Area新座席.Cells(R, C).Interior.Color = Color警告.同列
                Is現座席と新座席が同じ列の生徒を着色する = True
            End If
        Next
    Next
End Function

' 前後左右のチェック
Function Is前後左右が現座席に存在する新座席のペアを着色する() As Boolean
    Dim R As Long, C As Long
    
    ' Keyに「Aさん-Bさん」と全ペアをひとつの文字列で記録したDictionary　※Itemは不使用
    Dim Dic現座席全ペアリスト As Dictionary
    Set Dic現座席全ペアリスト = CreateDic前後左右全ペアリスト(Area現座席.Value)
    
    ' デバッグ用
    If isDebugモード Then Call Dictionaryを新規シートに出力する(Dic現座席全ペアリスト)
    
    ' 新座席の全ペアを走査し、Dictionaryに既登録であれば着色
    ' 前後
    For C = 1 To CCount座席
        For R = 1 To RCount座席 - 1
            If Dic現座席全ペアリスト.Exists(Area新座席.Cells(R, C) & "-" & Area新座席.Cells(R + 1, C)) Then
                Area新座席.Cells(R, C).Resize(2, 1).Interior.Color = Color警告.前後左右
                Is前後左右が現座席に存在する新座席のペアを着色する = True
            End If
        Next
    Next
    ' 左右
    For R = 1 To RCount座席
        For C = 1 To CCount座席 - 1
            If Dic現座席全ペアリスト.Exists(Area新座席.Cells(R, C) & "-" & Area新座席.Cells(R, C + 1)) Then
                Area新座席.Cells(R, C).Resize(1, 2).Interior.Color = Color警告.前後左右
                Is前後左右が現座席に存在する新座席のペアを着色する = True
            End If
        Next
    Next
    
End Function

' Keyに「Aさん-Bさん」と全ペアをひとつの文字列で記録したDictionary　※Itemは不使用
Function CreateDic前後左右全ペアリスト(Arr座席) As Dictionary
    Dim Dic As New Dictionary
    Dim R As Long, C As Long

    ' 前後のペアをDictionaryに格納
    For C = 1 To CCount座席
        For R = 1 To RCount座席 - 1
            Dic.Add Arr座席(R, C) & "-" & Arr座席(R + 1, C), Empty
            Dic.Add Arr座席(R + 1, C) & "-" & Arr座席(R, C), Empty ' 逆順も登録
        Next
    Next
    ' 左右のペアをDictionaryに格納
    For R = 1 To RCount座席
        For C = 1 To CCount座席 - 1
            Dic.Add Arr座席(R, C) & "-" & Arr座席(R, C + 1), Empty
            Dic.Add Arr座席(R, C + 1) & "-" & Arr座席(R, C), Empty ' 逆順も登録
        Next
    Next
    
    Set CreateDic前後左右全ペアリスト = Dic
    
End Function

' 着色のクリア
Sub ★新座席の着色をクリアする()
    Area新座席.Interior.ColorIndex = 0
End Sub

' 一括判定プロシージャ
Function Isすべての並び換えルールを満たす() As Boolean
    Isすべての並び換えルールを満たす = _
        Not (Is現座席と新座席が同じ行の生徒を着色する _
             Or Is現座席と新座席が同じ列の生徒を着色する _
             Or Is前後左右が現座席に存在する新座席のペアを着色する)
End Function

Ut_汎用関数

Option Explicit

' 行番号の検索
Function Match行番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Dim x: x = CDbl(検索値)
        If Err.Number = 0 Then
            Match行番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Row - 1
            Exit Function
        End If
    End If

    Match行番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Row - 1
    
End Function

' 列番号の検索
Function Match列番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Match列番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Column - 1
    Else
        Match列番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Column - 1
    End If
End Function

' Dictionaryを新規シートに出力する
Sub Dictionaryを新規シートに出力する(Dic As Dictionary)
    With Workbooks.Add.Worksheets(1)
        Call 配列をセルに出力する(.Range("A1"), Dic.Keys)
        Call 配列をセルに出力する(.Range("B1"), Dic.Items)
    End With
End Sub

' 1次元配列 → セル
Sub 配列をセルに出力する(出力始点セル As Range, Arr出力配列 As Variant _
    , Optional is行方向へ出力 As Boolean = True)

    If UBound(Arr出力配列) = -1 Then Exit Sub

    ' ◇ 要素数が1ならば単セルに出力
    If Count配列の要素数(Arr出力配列) = 1 Then
        出力始点セル.Value = Arr出力配列(0)
    
    ' Transposeで方向指定して出力
    ElseIf is行方向へ出力 Then
        出力始点セル.Resize(Count配列の要素数(Arr出力配列), 1) = Fx.Transpose(Arr出力配列)
    Else
        出力始点セル.Resize(1, Count配列の要素数(Arr出力配列)) = Fx.Transpose(Fx.Transpose(Arr出力配列))
    End If
    
End Sub

' 配列を新規シートに出力する
Sub 配列を新規シートに出力する(Arr)
    Workbooks.Add.Worksheets(1).Range("A1") _
        .Resize(Count配列の要素数(Arr, 1), Count配列の要素数(Arr, 2)) = Arr
End Sub

' 配列の要素数の取得
Function Count配列の要素数(Arr, Optional 次元 = 1) As Long
    Count配列の要素数 = UBound(Arr, 次元) - LBound(Arr, 次元) + 1
End Function

' 配列の次元数の取得
' 参考：https://www.limecode.jp/entry/utility/get-array-dimension
Function Get配列の次元数(Arr As Variant) As Long

    ' 渡された変数が配列ではない場合は0を返すこととする
    If IsArray(Arr) = False Then Get配列の次元数 = 0: Exit Function

    ' エラーが出るまでUBoundを取得してみる
    Dim tmp
    Dim 次元数 As Long: 次元数 = 0
    On Error Resume Next
    Do While Err.Number = 0
        次元数 = 次元数 + 1
        tmp = UBound(Arr, 次元数)
    Loop
    On Error GoTo 0

    ' エラーが出たひとつ前の次元が求める次元数
    Get配列の次元数 = 次元数 - 1
    
End Function

' セルのリストを1次元配列に
' 参考：https://www.limecode.jp/entry/utility/getarray-from-rangeobject
Function GetArrayセルのリストを1次元配列に変換する(セルリスト As Range) As Variant

    ' ◇ 単セル → 値そのまま
    If セルリスト.Cells.Count = 1 Then
        GetArrayセルのリストを1次元配列に変換する = Array(セルリスト.Value)
        Exit Function
    End If

    ' 1列データの時はTransposeで高速化
    If セルリスト.Areas.Count = 1 And セルリスト.Columns.Count = 1 And セルリスト.Count <= 65535 Then
        GetArrayセルのリストを1次元配列に変換する = Fx.Transpose(セルリスト)
        Exit Function
    End If

    ' それ以外は1セルずつ値を格納
    Dim Arr生成配列() As Variant
    ReDim Arr生成配列(1 To セルリスト.Cells.Count) As Variant
    
    Dim i As Long: i = 1
    Dim Cell As Range
    For Each Cell In セルリスト.Cells
        Arr生成配列(i) = Cell.Value
        i = i + 1
    Next

    GetArrayセルのリストを1次元配列に変換する = Arr生成配列

End Function

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

解説

並び替えのロジックとしては

  1. まずは行だけを並び替える(6グループのシャッフル)
  2. 続いて列だけを並び替える(6グループのシャッフル)
  3. 完成した席から無作為に2人を抽出し、その二人を並び替えても席替えルールに反しないならばその二人を入れ替える(2要素のスワップ)

という手順で行っております。

1と2だけでも「ルールを満たした並び替え」は実施できていることになりますが、
これだとルールを満たしているだけで規則性が見えてしまう点を考慮し、
最後に無作為抽出のスワップを300回追加で実行しています。


トランプを切る際、普通の切り方だけ、あるいはショットガンシャッフルだけで切った場合はランダムになるのに回数を要しますが、両者を交互に行った場合はものの数回でランダム(一様分布)になってくれます。

この性質を利用し、違うシャッフル法を混ぜて実行してみました。


行列のシャッフルには「シート数式」を利用しており、
123456を531624にする際、画像の数式群で行っています。

シャッフルを行う数式

この手のシャッフルはVBAだけで組むと結構大変ですが、
シート関数だとかなり簡潔に組めます。
　

  • 乱数の振り直しが「シートの再計算」で実行できる
  • 「全判定オールクリア」のチェックがAND(セル範囲)で一発

あたりが数式の強みですね。


続いて2要素のスワップは単純で、無作為に2人を選び入れ替えてみて、
それが条件を満たしているかを判定しているだけです。

判定についてはノック98本目の課題でしたので、
このロジックはこちらの記事をご参照ください。
www.limecode.jp