VBA100本ノック 99本目：自動席替え（行列と前後左右が全て違うように）

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

VBA100本ノック 99本目：自動席替え（行列と前後左右が全て違うように）

行列と前後左右が全て違うように席替えを自動で行う問題です。

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

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

マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。

出題

出題ツイートへのリンク

#VBA100本ノック 99本目
「座席表（現）」を「座席表（新）」へ自動で席替えをしてください。
席替えルールは98本目と同じ。
・全員が違う行列に移動
・前後左右は前回と違う人
※98本目を使い正しく配置できているか確認してください。

サンプルファイルは98本目の（新）の席を消しただけです。
https://excel-ubara.com/vba100sample/VBA100_99.xlsm
https://excel-ubara.com/vba100sample/VBA100_99.zip

VBA作成タイム

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

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

頂いた回答

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

解説

縦横に席をずらしていきます。
先頭行を1列ずらしたら、その次は2列ずらす。
左端列を1行ずらしたら、その次は2行ずらす。
実装にあたっては乱数を使って少し不規則に動くようにしたので、実行のたびに結果が変わってきます。
動画は、動きが分かるように途中表示させたものです。

大きさは限定していないので、5*5以上なら自由な大きさを指定できます。
4*4では数回に1回程度しかルールを満たさなくなります。
乱数で開始する隣席とのずらし方で結果が変わってきます。
この部分は若干複雑なのでVBAにコメントを入れておきました。


  
    
      Option Explicit


Sub VBA100_99_01()

　　Dim rngCur As Range: Set rngCur = Worksheets("座席表（現）").Range("B5:G10")

　　Dim rngNew As Range: Set rngNew = Worksheets("座席表（新）").Range("B5:G10")

　　

　　Call rotateSeat(rngCur, rngNew)

      　　

      　　'98本目のFunctionを使って席替え結果の妥当性確認

      　　Select Case checkSeat(rngCur, rngNew)


　　　　Case eResult.Ok: MsgBox "全席条件を満たしています。"

　　　　Case eResult.Ng: MsgBox "黄色セルの席は条件を満たしていません。"

　　　　Case eResult.Er: MsgBox "座席表（新）に席がない人がいます。"

　　End Select

End Sub


'座席を回転させる：移動量を変化させつつ横回転→縦回転

Sub rotateSeat(ByVal inRng As Range, ByVal outRng As Range)

　　Dim ary: ary = inRng.Value

      　　Dim i As Long, iPos As Long, iNum As Long, iStep As Long

　　

　　'1=横回転,2=縦回転

　　For i = 1 To 2

　　　　Randomize

　　　　'最初の回転量を乱数で変化させる：Ubound未満

　　　　iNum = Int(UBound(ary, i) * Rnd)

　　　　'隣の席との開始ずれ幅

　　　　iStep = Int(UBound(ary, i Mod 2 + 1) * Rnd) + 1

　　　　

　　　　'1=横回転なら1行目を横回転,2行目を横回転,3行目を横回転…

　　　　'2=縦回転なら1列目を縦回転,2列目を縦回転,3列目を縦回転…

　　　　For iPos = 1 To UBound(ary, i)

　　　　　　'iNum ：　　　　この数を前または左に回転

　　　　　　'iStep：　　　　隣席との移動差、移動量をずらしていく

　　　　　　'i Mod 2 + 1：　i=1→2,i=2→1、

　　　　　　'iStep：　　　　1→2→3→1

　　　　　　iNum = iNum + iStep

　　　　　　If iNum >= UBound(ary, i Mod 2 + 1) Then

　　　　　　　　iStep = iStep Mod 3 + 1

　　　　　　　　iNum = 1

　　　　　　End If

      　　　　　　ary = rotateArray(ary, i Mod 2 + 1, iPos, iNum)

　　　　Next

　　Next

　　

　　outRng.Value = ary

End Sub


'配列を縦か横で指定位置を指定量を回転させる

'aAry　 : 配列

'aDim　 : 回転させる次元

'aPos　 : 移動位置

'aNum　 : 移動量

Function rotateArray(ByRef aAry, ByVal aDim As Long, ByVal aPos As Long, ByVal aNum As Long) As Variant

　　Dim rtnAry: rtnAry = aAry

　　

　　Dim i As Long, j As Long, LB As Long, UB As Long

　　LB = LBound(aAry, aDim)

　　UB = UBound(aAry, aDim)

　　

　　For i = LB To UB

　　　　'aNum回転させるための元位置と先位置の変換

　　　　If i <= aNum Then

　　　　　　j = i + UB - aNum

　　　　Else

　　　　　　j = i - aNum

　　　　End If

　　　　

　　　　'aDim次元目を回転

　　　　If aDim = 1 Then

　　　　　　rtnAry(j, aPos) = aAry(i, aPos) '縦回転

　　　　Else

　　　　　　rtnAry(aPos, j) = aAry(aPos, i) '横回転

　　　　End If

　　Next

　　

　　rotateArray = rtnAry

End Function

この問題は、課題をどう解決するかを問う問題として捉えてもらえば良いと思います。
様々な方法での回答がありますので、是非参考にしてください。
記事にはVBAと、若干の追加説明をしました。

補足

様々な解き方

・事前にルールを満たす移動位置を求めておき、その位置へ動かす
・ルールを満たすように1席ずつ決めていき破綻したらやり直し（再帰含む）
・6*6の行列を隣席とは違う動きで移動させる

大きく分けるとこのくらいではないかと思います。
私の方法は最後の行列を動かす方法に分類できると思います。

前掲VBAの補足説明

乱数を使うことで、くじ引き的な要素を入れてみました。
席替えといえば・・・青春・・・期待と失望・・・
遠い昔の事で良く覚えていませんが、そんな記憶がかすかに・・・

最初は行列ともに移動させるので、斜めに移動させようかと考えたのですが、VBAがちょっと難しくなりそうに思いました。
そこでルービックキューブのように、縦と横を別々に動かすことにしました。
縦を動かして横を動かせば、行列位置は変わります。
隣席とは違う移動量にすれば、隣席とは離れた位置に移動することになります。

この方法が決まればVBAはそんなに難しくありません。
配列を縦回転、横回転させるだけで済みます。

前掲のVBAが、少し複雑になっているのは、
・6*6以外でも処理可能
・結果をランダムに変化
この2点を実装したためで、やっていることは配列の指定次元の指定インデックスを回転させているだけです。

5*5以上なら必ず1回でルール通りの席替えが出来ているので、失敗時のリトライはしていません。
4*4の場合には数回に1回くらいしかルール通りに席替え出来ないので、この場合はループさせる必要があると思います。
ただし、そもそも4*4でこのルールはあまり意味があるとも思えませんが。


  
    
      Dim cnt As Long

Do

　　Call rotateSeat(rngCur, rngNew)

　　If checkSeat(rngCur, rngNew) = eResult.Ok Then Exit Do

      　　cnt = cnt + 1: If cnt > 100 Then Exit Do

Loop

乱数を使っているので結果は実行のたびごとに違ってきます。
ただし、もちろん、席のパターンは有限数になります。
数学得意な人なら計算で出せるかもしれませんが・・・

6*6で数千回実行させて結果の席のパターンを保存していったところ、212パターンが作成されました。
ルールを満たすパターンはもっとあると思いますが、このVBAの方法ではということです。
つまり、1回の実行では200パターンの中からランダムに選ばれると考えれば良いと思います。
ただし、乱数の使い方が均一ではないので発生パターンには偏りがあり、同じパターンが良く出るといったこともあるようです。

サイト内関連ページ

第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本ノックのリストを取得
 魔球編：組み合わせ問題
 魔球編：閉領域の塗り潰し
 迷宮編：巡回セル問題
 魔球編：2桁の最小公倍数
 参加者様ご紹介

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

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

ホーム
マクロVBA入門編
VBA100本ノック
99本目：自動席替え（行列と前後左右が全て違うように）

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

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

VBA練習問題
VBA100本ノック 99本目：自動席替え（行列と前後左右が全て違うように）