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

VBAを100本の練習問題で鍛えます
最終更新日:2021-03-02

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


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


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

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。
マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。


出題

出題ツイートへのリンク

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

マクロ VBA 100本ノック

マクロ VBA 100本ノック


サンプルファイルです。
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本ノックのリストを取得
魔球編:組み合わせ問題
魔球編:閉領域の塗り潰し
迷宮編:巡回セル問題
魔球編:2桁の最小公倍数


新着記事NEW ・・・新着記事一覧を見る

抜けている数値を探せ|エクセル雑感(2022-07-01)
.Net FrameworkのSystem.Collectionsを利用|VBA技術解説(2022-06-29)
迷路ネコが影分身の術を体得したら…|エクセル雑感(2022-06-27)
迷路にネコが挑戦したら、どうなるかな…|エクセル雑感(2022-06-26)
サロゲートペアに対応した自作関数(Len,Left,Mid,Right)|エクセル雑感(2022-06-24)
「マクロの登録」で登録できないプロシージャーは?|エクセル雑感(2022-06-23)
オブジェクトのByRef、ByVal、Variant|エクセル雑感(2022-06-22)
コメントから特定形式の年月を取り出す|エクセル雑感(2022-06-19)
4,9を使わない連番作成|エクセル雑感(2022-06-17)
連番を折り返して出力|エクセル雑感(2022-06-16)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.繰り返し処理(For Next)|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.Excelショートカットキー一覧|Excelリファレンス
7.マクロって何?VBAって何?|VBA入門
8.並べ替え(Sort)|VBA入門
9.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
10.エクセルVBAでのシート指定方法|VBA技術解説




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


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



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