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

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

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


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


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

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


出題

出題ツイートへのリンク

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

マクロ VBA 100本ノック

マクロ VBA 100本ノック


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


VBA作成タイム

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


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


頂いた回答

解説

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

マクロ VBA サンプル画像


大きさは限定していないので、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)
マクロVBAにおける配列の説明として最初に静的配列を解説しました。静的配列では要素数は宣言時点で決められていました。しかし、プログラミングをする上で、実行時点で要素数を決めたい場合や、実行途中で要素数を増減させたい場合が多く出てきます。
第113回.配列に関連する関数
マクロVBAで配列を使う上で、必要となるVBA関数がいくつかあります。より便利に配列を活用するために必須となるVBA関数、・LBound関数 ・UBound関数 ・Array関数 ・IsArray関数 ・Join関数 ・Filter関数 以上のVBA関数について解説します。
第114回.セル範囲⇔配列(マクロVBA高速化必須テクニック)
セル範囲をVariant型変数に入れる事で、配列を作成することができます。また、配列をセル範囲にまとめて出力する事も出来ます。これは、マクロVBAを高速処理したい時の必須テクニックになります、マクロの処理が遅い場合は、このテクニックが使えないか検討してください。
Dictionary(ディクショナリー)連想配列の使い方について
「Dictionaryオブジェクトについて簡単な使用例を上げて解説して欲しいです。」との要望をいただいたので、Dictionaryについて基本的な使い方を解説します。Dictionary(ディクショナリー)は名前の通り、辞書機能であり、連想配列とも呼ばれます。
Dictionary(ディクショナリー)のパフォーマンスについて
Dictionary(ディクショナリー)は辞書機能で、連想配列とも呼ばれます。この辞書は、重複は許されず、キーとデータの2つが存在します、今回はこのDictionaryのパフォーマンス(処理速度)を検証します。Dictionaryの基本的な使い方については、こちらを参照してください。




同じテーマ「VBA100本ノック」の記事

93本目:複数ブックを連結して再分割
94本目:表範囲からHTMLのtableタグを作成
95本目:図形のテキストを検索するフォーム作成
96本目:Accessデータを取得(マスタ結合&抽出)
97本目:Accessデータを取得(グループ集計)
98本目:席替えルールが守られているか確認
99本目:自動席替え(行列と前後左右が全て違うように)
100本目:WEBから100本ノックのリストを取得
魔球編:組み合わせ問題
魔球編:閉領域の塗り潰し
迷宮編:巡回セル問題


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

エクセル関連で「いいね」の多かったツイート|エクセル雑感(2021-05-17)
キーボード操作だけで非表示列を表示|エクセル雑感(2021-05-11)
変数を考えることはロジックを考える事|エクセル雑感(2021-04-11)
RangeオブジェクトのFor EachとAreasについて|VBA技術解説(2021-04-08)
PropertyのSetはLetでも良い|VBA技術解説(2021-03-31)
エクセル麻雀ミニゲーム|VBAサンプル集(2021-03-09)
VBA100本ノック 100本目:WEBから100本ノックのリストを取得|VBA練習問題(2021-03-03)
VBA100本ノック 魔球編:2桁の最小公倍数|VBA練習問題(2021-02-02)
Select Caseでの短絡評価(ショートサーキット)の使い方|VBA技術解説(2021-01-03)
VBA100本ノック 迷宮編:巡回セル問題|VBA練習問題(2020-12-31)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.Excelショートカットキー一覧|Excelリファレンス
3.変数宣言のDimとデータ型|VBA入門
4.RangeとCellsの使い方|VBA入門
5.マクロって何?VBAって何?|VBA入門
6.繰り返し処理(For Next)|VBA入門
7.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
8.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
9.セルに文字を入れるとは(Range,Value)|VBA入門
10.とにかく書いてみよう(Sub,End Sub)|VBA入門




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


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



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