VBA100本ノック 98本目：席替えルールが守られているか確認
席替え前と後で、席替えルールが守られているか確認する問題です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。
マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。
出題
出題ツイートへのリンク
#VBA100本ノック 98本目
以下のルールで席替え（現→新）をしました。
・全員が違う行列に移動
・前後左右は前回と違う人
例.B2「阿久津 美嘉」
・B列以外かつ2行目以外へ
・前後左右に「森井 さんま,赤坂 法子,石橋 倫子,長野 扶樹」はNG。斜めはOK。
ルールに反する席は（新）に色を塗ってください。
サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_98.xlsm
https://excel-ubara.com/vba100sample/VBA100_98.zip
以下のルールで席替え（現→新）をしました。
・全員が違う行列に移動
・前後左右は前回と違う人
例.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を（現）と（新）の両方で作成。
このDictionaryどうしの比較でルールをチェックしています。
前後左右が範囲外の場合の空白セル等の対応としてセル番地を入れておくことで後での比較をしやすくしました。
前後左右の4か所どうしの比較部分をどのようにVBAで書くかが少し悩ましいですが、そこだけ気を付ければ良い問題だと思います。
記事にはVBAを掲載しています。
今回は席替え結果のチェックでした。さて次の99本目でこのルールで自動席替えをします。
この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本目でこのルールで自動席替えをします。
補足
補足はありません。
サイト内関連ページ
第112回．動的配列（ReDim）
・ReDimステートメント ・要素数の変更について ・配列について
第113回．配列に関連する関数・LBound関数とUBound 関数 ・Array関数 ・IsArray 関数 ・Join関数 ・Filter関数 ・Eraseステートメント
第114回．セル範囲⇔配列（マクロVBA高速化必須テクニック）・セル範囲⇔配列の基本VBA ・使用例 ・配列およびマクロVBAの高速化に関するページ
Dictionary（ディクショナリー）連想配列の使い方について・Dictionaryを使って重複を除く ・Dictionaryの使い方その2 ・Dictionaryの使い方その3 ・Dictionaryの使い方サンプル ・サイト内のDictionary関連記事
Dictionary（ディクショナリー）のパフォーマンスについて・Dictionaryの検証に使うシート ・ユニーク化（重複削除）の方法について ・Dictionaryでユニーク化1 ・Dictionaryでユニーク化2 ・Dictionaryでユニーク化3 ・Dictionaryでユニーク化4 ・最初のVBAはなぜ遅かったのか ・Dictionaryを使わない方法 ・サイト内の関連ページ
同じテーマ「VBA100本ノック」の記事
・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
95本目：図形のテキストを検索するフォーム作成・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
96本目：Accessデータを取得（マスタ結合&抽出）・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
97本目：Accessデータを取得（グループ集計）・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
98本目：席替えルールが守られているか確認99本目：自動席替え（行列と前後左右が全て違うように）
・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
100本目：WEBから100本ノックのリストを取得・出題 ・頂いた回答 ・解説 ・補足 ・サイト内関連ページ
魔球編：組み合わせ問題・出題 ・頂いた回答 ・解答 ・補足
魔球編：閉領域の塗り潰し・出題 ・頂いた回答 ・解答 ・解答VBAコード
迷宮編：巡回セル問題・出題 ・頂いた回答 ・解答VBAコードの解説 ・解答VBAコード ・中間地点数10個～15個での処理時間比較
魔球編：2桁の最小公倍数・出題 ・頂いた回答 ・解答 ・解答VBAコード
新着記事NEW ・・・新着記事一覧を見る
ブール型（Boolean）のis変数・フラグについて｜VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する｜VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次｜エクセルの神髄(2024-03-20)
VBA10大躓きポイント（初心者が躓きやすいポイント）｜VBA技術解説(2024-03-05)
テンキーのスクリーンキーボード作成｜ユーザーフォーム入門(2024-02-26)
無効な前方参照か、コンパイルされていない種類への参照です。｜エクセル雑感(2024-02-17)
初級脱出10問パック｜VBA練習問題(2024-01-24)
累計を求める数式あれこれ｜エクセル関数応用(2024-01-22)
複数の文字列を検索して置換するSUBSTITUTE｜エクセル入門(2024-01-03)
いくつかの数式の計算中にリソース不足になりました。｜エクセル雑感(2023-12-28)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得（End,Rows.Count）｜VBA入門
2.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
3.RangeとCellsの使い方｜VBA入門
4.ひらがな⇔カタカナの変換｜エクセル基本操作
5.繰り返し処理（For Next)｜VBA入門
6.変数宣言のDimとデータ型｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.Findメソッド（Find,FindNext,FindPrevious）｜VBA入門
- ホーム
- マクロVBA入門編
- VBA100本ノック
- 98本目：席替えルールが守られているか確認
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。