和風スパゲティのレシピ

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

トップ > 100本ノック > 98本目：席替えルールが守られているか確認

98本目：席替えルールが守られているか確認

100本ノック VBA

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

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

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

以下のルールで席替え（現→新）をしました。
・全員が違う行列に移動
・前後左右は前回と違う人
例.B2「阿久津 美嘉」
・B列以外かつ2行目以外へ
・前後左右に「森井 さんま,赤坂 法子,石橋 倫子,長野 扶樹」はNG。斜めはOK。
ルールに反する席は（新）に色を塗ってください。

ノック98本目：席替えルールが守られているか確認

◇ 出題ページはこちら

ソースコード

モジュール一覧

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

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

解説

席替え後の行・列が同じになっている生徒がいないかのチェックについては、
単純に各生徒を現座席の同行・同列内から検索して判定しました。

セルの検索にはMatch関数が便利なため、これを汎用関数化しています。


さてこの問題の肝となるのは「前後左右に現座席と同じ生徒がいないか」ですが、
こちらはすべての現座席ペアを「Aさん-Bさん」とハイフンでつないだ文字列にして、
DictionaryのKeyとして登録するロジックを用いました。

逆順も判定する必要があるため「A-B」「B-A」を両方登録しています。


こうすることで、新座席の前後左右ペアの現座席との重複チェックは、
隣り合う二人を「-」でつないでDictionary.Existsで判定すれば良いことになります。


存在チェック系はDictionaryを用いるのが簡潔にかけておすすめですね。


その他コーディングのポイントとしては、
ルールの判定をTrue/Falseを返すFunctionで実装しておき、
完了通知or警告は実行モジュールで行っている点です。

こうしておかないと、続くノック99本目でただ判定を行いたいときに、
MsgBoxが邪魔でコードの流用が難しくなってしまいますからね。


このあたりのプロシージャ分割のやり方も参考にしてみてください。