VBA100本ノック 98本目：席替えルールが守られているか確認
席替え前と後で、席替えルールが守られているか確認する問題です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。
出題
以下のルールで席替え（現→新）をしました。
・全員が違う行列に移動
・前後左右は前回と違う人
例.B2「阿久津 美嘉」
・B列以外かつ2行目以外へ
・前後左右に「森井 さんま,赤坂 法子,石橋 倫子,長野 扶樹」はNG。斜めはOK。
ルールに反する席は（新）に色を塗ってください。
https://excel-ubara.com/vba100sample/VBA100_98.xlsm
https://excel-ubara.com/vba100sample/VBA100_98.zip
VBA作成タイム
この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。
他の人の回答および解説を見て、書いたVBAを見直してみましょう。
頂いた回答
解説
このDictionaryどうしの比較でルールをチェックしています。
前後左右が範囲外の場合の空白セル等の対応としてセル番地を入れておくことで後での比較をしやすくしました。
Option Explicit
Enum eResult
Ok = 0
Ng = 1
Er = 9
End Enum
Sub VBA100_98_01()
Dim rngCur As Range: Set rngCur = Worksheets("座席表（現）").Range("B5:G10")
Dim rngNew As Range: Set rngNew = Worksheets("座席表（新）").Range("B5:G10")
Select Case checkSeat(rngCur, rngNew)
Case eResult.Ok: MsgBox "全席条件を満たしています。"
Case eResult.Ng: MsgBox "黄色セルの席は条件を満たしていません。"
Case eResult.Er: MsgBox "座席表（新）に席がない人がいます。"
End Select
End Sub
'座席ルール確認のメイン処理
Function checkSeat(ByVal rngCur As Range, ByVal rngNew As Range) As eResult
checkSeat = eResult.Ok
rngNew.Interior.Color = xlNone
Dim dicCur As Dictionary: Set dicCur = createDic(rngCur)
Dim dicNew As Dictionary: Set dicNew = createDic(rngNew)
Dim rng As Range, i As Long, vKey, vCur, vNew
For Each vKey In dicCur
'（新）に席がない場合のチェック
If Not dicNew.Exists(vKey) Then
checkSeat = eResult.Er
Exit Function
End If
'行列前後左右の確認
vCur = dicCur(vKey): vNew = dicNew(vKey)
If Not checkRCUDLR(vCur, vNew) Then
rngNew.Cells(vNew(0), vNew(1)).Interior.Color = vbYellow
checkSeat = eResult.Ng
End If
Next
End Function
'行列前後左右の確認：0=行,1=列,2={上,3=下,4=左,5=右}
Function checkRCUDLR(ByVal aCur, ByVal aNew) As Boolean
checkRCUDLR = False
If aCur(0) = aNew(0) Or aCur(1) = aNew(1) Then Exit Function
Dim v
For Each v In aCur(2)
'Filter結果（常に0開始）が1つは一致
If UBound(Filter(aNew(2), v)) = 0 Then
Exit Function
End If
Next
checkRCUDLR = True
End Function
'各席情報を辞書に登録:'0=行,1=列,2={上,3=下,4=左,5=右}
Function createDic(ByVal aRng As Range) As Dictionary
Dim dic As New Scripting.Dictionary
Dim rng As Range
For Each rng In aRng
dic(rng.Value) = Array(rng.Row - aRng.Row + 1, _
rng.Column - aRng.Column + 1, _
Array(getValue(aRng, rng, -1, 0), _
getValue(aRng, rng, 1, 0), _
getValue(aRng, rng, 0, -1), _
getValue(aRng, rng, 0, 1)))
Next
Set createDic = dic
End Function
'座席範囲内ならValue、範囲外ならセル番地（隣接セルの空白や同値の対応）
Function getValue(ByVal aRng As Range, ByVal aTargetRng As Range, aRow As Long, aCol As Long) As String
If Intersect(aRng, aTargetRng.Offset(aRow, aCol)) Is Nothing Then
getValue = aTargetRng.Offset(aRow, aCol).Address
Else
getValue = aTargetRng.Offset(aRow, aCol).Value
End If
End Function
記事にはVBAを掲載しています。
今回は席替え結果のチェックでした。さて次の99本目でこのルールで自動席替えをします。
補足
サイト内関連ページ
同じテーマ「VBA100本ノック」の記事
94本目：表範囲からHTMLのtableタグを作成
95本目：図形のテキストを検索するフォーム作成
96本目：Accessデータを取得（マスタ結合&抽出）
97本目：Accessデータを取得（グループ集計）
98本目：席替えルールが守られているか確認
99本目：自動席替え（行列と前後左右が全て違うように）
100本目：WEBから100本ノックのリストを取得
魔球編：組み合わせ問題
魔球編：閉領域の塗り潰し
迷宮編：巡回セル問題
魔球編：2桁の最小公倍数
新着記事NEW ・・・新着記事一覧を見る
シートコピー後のアクティブシートは何か｜ツイッター出題回答 (2023-09-19)
Excel関数の引数を省略した場合について｜ツイッター出題回答 (2023-09-14)
セル個数を返すRange.CountLargeプロパティとは｜VBA技術解説(2023-09-08)
記号を繰り返してグラフ作成（10単位で折り返す）｜ツイッター出題回答 (2023-08-28)
シートを削除：不定数のシート名に対応｜VBAサンプル集(2023-08-24)
ランクによりボイントを付ける（同順位はポイントを分割）｜ツイッター出題回答 (2023-08-22)
OneDrive使用時のThisWorkbook.Pathの扱い方｜VBA技術解説(2023-07-26)
列幅不足による###表示や指数表示を判定する｜VBA技術解説(2023-07-12)
シートを削除：不定数のシート名に対応｜VBAサンプル集(2023-07-04)
シート関数のCOUNTIFS,SUMIFS,MAXIFSと同じ処理｜Power Query（M言語）入門(2023-02-28)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.RangeとCellsの使い方｜VBA入門
3.繰り返し処理（For Next)｜VBA入門
4.変数宣言のDimとデータ型｜VBA入門
5.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
6.マクロとは？VBAとは？VBAでできること｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
10.条件分岐（IF）｜VBA入門
- ホーム
- マクロVBA入門編
- VBA100本ノック
- 98本目：席替えルールが守られているか確認
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。