ランダム座席表マクロ

ランダム席替えマクロ

作ってみた。

座席表の枠を作ったシートの機能なので、シートモジュールに生やしてみた。

準備

ランダムに並べるために、乱数発生用のメソッドを用意する。

今回は、標準モジュールにRandUtilと名前を付け、RandUtilモジュールのメソッド、という形にした。

リスト１　標準モジュールRandUtil

Public Function getRandomOrder( _
            ByVal maxNumber As Long, _
   Optional ByVal allowDuplicate As Boolean = False) As Long()
'///1～maxNumまでの整数をランダムに並べて配列に格納する。'
'///引数maxNum：最大数'
'///引数allowDuplicate：重複を許可するならTrue'
  Dim ret() As Long
  Dim hasSet() As Boolean
  ReDim hasSet(maxNumber - 1)
  Dim i As Long
  ReDim ret(maxNumber - 1)
  Randomize
  Dim tmp As Long
  For i = 0 To maxNumber - 1
    Do
      tmp = Int(maxNumber * Rnd + 1)
    '///乱数：Int((最大値 - 最小値 + 1) * Rnd + 最小値)'
    Loop Until hasSet(tmp - 1) = False
    ret(i) = tmp
    If Not allowDuplicate Then hasSet(tmp - 1) = True
  Next
  getRandomOrder = ret
End Function

数字をランダムに並べ替えて配列にして返すメソッド。

重複回避のためにBoolean型配列を使うやり方は、たぶん昔

www.moug.net

で見つけたのだった。

既に使われた数字かどうかの判定を常にイチから総当たりにしているので、数が多くなればなるほど計算回数が爆発的に増える。したがって、サイズの大きなデータを扱うにはまったく適していないと思うが、せいぜい何十人までのデータを扱うだけならばこれで充分だろう。

シャッフルされた番号をセットしていくマクロ

上掲のgetRandomOrderメソッドによって、シャッフルされた番号のセット（配列）が受け取れるので、あとは配列の中身を順に番号記入セルに入力していけば良い。

リスト２　シートモジュール

Option Explicit

Private Const COLUMN_NUMBERS As String = _
                "2 4 7 9 12 14"
Private Const COLUMNS_COUNT As Long = 6    '……(1)'
Private Const MAX_NUMBER As Long = 30

Private Sub setSeatAtRandom()
  Dim randOrder() As Long    '……(2)'
  randOrder = RandUtil.getRandomOrder(MAX_NUMBER, False)
  Dim r As Long
  Dim c As Long
  Dim i As Long
  For i = 1 To MAX_NUMBER    '……(3)'
    r = getRowNumber(i)    '……(4)'
    c = getColumnNumber(i)    '……(6)'
    If r = -1 Or c = -1 Then Exit Sub    '……(7)'
    Me.Cells(r, c).Value = ""    '……(8)'
    Me.Cells(r, c).Value = randOrder(i - 1)
    Call setFontColor(Me.Cells(r, c))    '……(9)'
  Next
End Sub

Private Function getRowNumber( _
             ByVal number As Long) As Long    '……(5)'
  Dim ret As Long
  ret = -1
  If number < 1 Or _
     number > MAX_NUMBER Then GoTo Finalizer
  On Error GoTo Finalizer
  ret = ((number - 1) \ COLUMNS_COUNT) * 3 + 3
Finalizer:
  getRowNumber = ret
End Function

Private Function getColumnNumber( _
             ByVal number As Long) As Long
  Dim ret As Long
  ret = -1
  If number < 1 Or _
     number > MAX_NUMBER Then GoTo Finalizer
  On Error GoTo Finalizer
  Dim ar() As String
  ar = Split(COLUMN_NUMBERS)
  Dim targetIndex As Long
  targetIndex = (number - 1) Mod COLUMNS_COUNT
  ret = CLng(ar(targetIndex))
Finalizer:
  getColumnNumber = ret
End Function

Private Sub setFontColor(ByVal targetCell As Range)
  Dim rng As Range
  Set rng = targetCell.Resize(2, 2)    '……(10)'
  With targetCell    '……(11)'
    If .Value = 0 Or .Value = "" Then
      rng.Font.Color = vbWhite
    Else
      rng.Font.Color = vbBlack
    End If
  End With
End Sub

(1)の

Private Const COLUMNS_COUNT As Long = 6

は、前回

akashi-keirin.hatenablog.com

はなかった定数。今回は、getColumnNumberメソッドに加え、getRowNumberメソッドを追加したので、両方に共通する部分を定数にした方が良いと判断した。

(2)の

Dim randOrder() As Long
randOrder = RandUtil.getRandomOrder(MAX_NUMBER, False)

では、リスト１のgetRandomOrderメソッドにより、1～30までの数字をランダムに並べ替えた配列を準備。

(3)からの８行

For i = 1 To MAX_NUMBER
  r = getRowNumber(i)    '……(4)'
  c = getColumnNumber(i)    '……(6)'
  If r = -1 Or c = -1 Then Exit Sub    '……(7)'
  Me.Cells(r, c).Value = ""    '……(8)'
  Me.Cells(r, c).Value = randOrder(i - 1)
  Call setFontColor(Me.Cells(r, c))    '……(9)'
Next

で各番号記入用セルに番号を書き込んでいく。

Forループ内では、まず(4)の

r = getRowNumber(i)

で書き込み先セルの行番号を取得する。

(5)の

Private Function getRowNumber( _
             ByVal number As Long) As Long
  Dim ret As Long
  ret = -1
  If number < 1 Or _
     number > MAX_NUMBER Then GoTo Finalizer
  On Error GoTo Finalizer
  ret = ((number - 1) \ COLUMNS_COUNT) * 3 + 3
Finalizer:
  getRowNumber = ret
End Function

で、書き込み先セルがいくつ目のセルなのかに応じて行番号を割り出している。

前回ご紹介したgetColumnNumberメソッド同様、あり得ない番号が渡されたときは、-1を返すようにしている。

(6)の

c = getColumnNumber(i) 

は、書き込み先セルの列番号取得。

getColumnNumberメソッドの内容については前回を参照のこと。

(7)の

If r = -1 Or c = -1 Then Exit Sub

で取得した値のチェック。

getRowNumberメソッドにせよ、getColumnNumberメソッドにせよ、うまく行っていなかったら-1を返すようにしているので、もしどちらか一方でも-1が返っていたら処理を抜ける。

(8)の

Me.Cells(r, c).Value = ""
Me.Cells(r, c).Value = randOrder(i - 1)

で一旦セルの値を消してからシャッフルした番号をぶちこんだ配列の値をセット。

そして、(9)の

Call setFontColor(Me.Cells(r, c))

でsetFonColorメソッドを呼ぶ。

setFonColorメソッド内では、(10)の

Set rng = targetCell.Resize(2, 2)

で、引数で受け取ったtargetCellを２×２の大きさに拡張し、変数rngにぶち込む。

あとは、(11)からの７行

With targetCell
  If .Value = 0 Or .Value = "" Then
    rng.Font.Color = vbWhite
  Else
    rng.Font.Color = vbBlack
  End If
End With

で、番号入力セルの値に応じてフォントの色を白にしたり、黒にしたりする。

今回のマクロでは「0」とか「""」が入る可能性はないのだけれど、今後の拡張のために入れておいた。

今回用いた座席表の枠では、番号入力セル以外の三つのセルには全てVLOOKUPを用いた数式が入っているので、番号入力セルの値が「0」とか「""」だと、＃N/Aが表示されてしまう。

もちろんIFERRORなんかでネストすれば防げるが、あまり複雑な数式を多用するのもアレなので、このような対応にした。

実行

シート上にコマンドボタンを置いて、今回のマクロを登録、実行してみた。

こんな感じ。

おわりに

実用の場面では、並べ替え用名簿を別に作っておき、シャッフルした後色んな条件で並べ替えてから、座席表に配置するなど、いろいろ工夫すると良いでしょう。