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

公開日：2021-03-01　最終更新日：2021-03-02

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

席替え前と後で、席替えルールが守られているか確認する問題です。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。

マクロ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

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。

他の人の回答および解説を見て、書いたVBAを見直してみましょう。

頂いた回答

出題ツイートの引用ツイートでの回答

解説

座席の名前をキーとして、座席の行列位置と前後左右の名前を値にしたDictionaryを（現）と（新）の両方で作成。
この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

前後左右の4か所どうしの比較部分をどのようにVBAで書くかが少し悩ましいですが、そこだけ気を付ければ良い問題だと思います。
記事には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本ノック」の記事

94本目：表範囲からHTMLのtableタグを作成

・出題・頂いた回答・解説・補足・サイト内関連ページ

95本目：図形のテキストを検索するフォーム作成

・出題・頂いた回答・解説・補足・サイト内関連ページ

96本目：Accessデータを取得（マスタ結合&抽出）

・出題・頂いた回答・解説・補足・サイト内関連ページ

97本目：Accessデータを取得（グループ集計）

・出題・頂いた回答・解説・補足・サイト内関連ページ

98本目：席替えルールが守られているか確認
99本目：自動席替え（行列と前後左右が全て違うように）

・出題・頂いた回答・解説・補足・サイト内関連ページ

100本目：WEBから100本ノックのリストを取得

・出題・頂いた回答・解説・補足・サイト内関連ページ

魔球編：組み合わせ問題

・出題・頂いた回答・解答・補足

魔球編：閉領域の塗り潰し

・出題・頂いた回答・解答・解答VBAコード

迷宮編：巡回セル問題

・出題・頂いた回答・解答VBAコードの解説・解答VBAコード・中間地点数10個～15個での処理時間比較

魔球編：2桁の最小公倍数

・出題・頂いた回答・解答・解答VBAコード

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.繰り返し処理（For Next)｜VBA入門
3.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
4.変数宣言のDimとデータ型｜VBA入門
5.RangeとCellsの使い方｜VBA入門
6.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
7.セルのクリア（Clear,ClearContents）｜VBA入門
8.メッセージボックス(MsgBox関数)｜VBA入門
9.条件分岐（Select Case）｜VBA入門
10.ブック・シートの選択（Select,Activate）｜VBA入門

ホーム
マクロVBA入門編
VBA100本ノック
98本目：席替えルールが守られているか確認

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

VBA練習問題
VBA100本ノック 98本目：席替えルールが守られているか確認