席替えを自動で行う:Excel VBA入門

スポンサードリンク

はじめに　　　Topへ

学校などの席替えをVBAで処理してみようと思います。
ここで使用しているのはExcel2010です。
一応、Excel2002でも動かせましたが、ほかのバージョンでは不具合があるかもしれません。
ここでは、オートシェイプを机に見立ててシートに必要数配置します。
生徒名のリストはSheet2へあらかじめ作成しているものとします。
乱数をSheet2の生徒リストに入れ、この乱数と一致した座席に名前を入力するという方法です。
サンプルはこちらからダウンロードできます。→　HP2010_sekigae.xlsm(Excel2010のマクロ付ファイル：約50KB)　
- 席替えをくじ引きで行う　も作成しています。

生徒のリストをSheet2へ作成する　　　Topへ

Sheet2のB列に下図のように生徒名のリストを作成します。
C列にはVBAで乱数が入りますので、空欄のままでOKです。

座席(机)を描画する　　　Topへ

Sheet1の列に下図のような座席(机)を描画します。

描画した机はセル範囲B1:G8の中であれば、移動してもOKです。
描画した時につけた名前をキーにしていますので、位置は関係ありません。

Sub seat01()
　　Dim c As Range, ob As Object
　　Dim myShape As Shape
　　Dim i As Long, n As Long

　　'　nで座席数(生徒数)を指定
　　　　n = Application.WorksheetFunction.CountA(Worksheets("Sheet2").Range("B:B")) - 1

　　　　With Worksheets("Sheet1")
　　　　　　' B1:G20の範囲のオブジェクトを削除
　　　　　　For Each ob In .DrawingObjects
　　　　　　　　If Not Intersect(ob.TopLeftCell, .Range("B1:G20")) Is Nothing Then
　　　　　　　　　　ob.Delete
　　　　　　　　End If
　　　　　　Next

　　　　　　'　行高さ、列幅を指定
　　　　　　.Rows("1:10").RowHeight = 35
　　　　　　.Columns("B:G").ColumnWidth = 15

　　　　　　'　座席を描画する、描画したオートシェイプの名前は「座席」+数字としています
　　　　　　For Each c In .Range("B2:G8")
　　　　　　　　i = i + 1
　　　　　　　　If n < i Then Exit For
　　　　　　　　Set myShape = .Shapes.AddShape( _
　　　　　　　　　　　Type:=5, _
　　　　　　　　　　　Left:=c.Left, _
　　　　　　　　　　　Top:=c.Top, _
　　　　　　　　　　　Width:=c.Width - 15, _
　　　　　　　　　　　Height:=c.Height - 10)

　　　　　　　　myShape.Name = "座席" & i
　　　　　　　　myShape.TextFrame.Characters.Text = myShape.Name
　　　　　　Next c

　　　　　　'　教卓を描画しています

　　　　　　Set myShape = .Shapes.AddShape( _
　　　　　　　　　Type:=5, _
　　　　　　　　　Left:=.Range("D1").Left + 30, _
　　　　　　　　　Top:=.Range("D1").Top, _
　　　　　　　　　Width:=.Range("D1").Width, _
　　　　　　　　　Height:=.Range("D1").Height - 10)

　　　　　　　　　myShape.Name = "教卓"
　　　　　　　　　myShape.TextFrame.Characters.Text = myShape.Name
　　　　　　.Range("A1").Select
　　　　End With
End Sub

実行後の画面

乱数を作成し、Sheet2へ入力する　　　Topへ

Sheet2の生徒リストのC列へ乱数を入力します。

ここで使用しているコードは　重複しないランダムな数値を得る方法　で説明しているものです。

Sub 乱数01()
　　Dim i As Long
　　Dim x()
　　Dim y()
　　Dim d
　　Dim Ud as Long
　　　　'---開始値Ldと終了値Udを定数で指定
　　　　Const Ld = 1
　　　　 Ud = Application.WorksheetFunction.CountA(Worksheets("Sheet2").Range("B:B")) - 1
　　　　'----使用する配列を準備する
　　　　ReDim x(1 To Ud - Ld + 1)
　　　　ReDim y(1 To Ud - Ld + 1)
　　　　ReDim d(1 To Ud - Ld + 1, 1 To 1)
　　　　Randomize
　　　　'----乱数と値を配列にセットする
　　　　For i = 1 To Ud - Ld + 1
　　　　　　x(i) = Rnd()
　　　　　　y(i) = i + Ld - 1
　　　　Next i
　　　　'----値を取り出す
　　　　For i = 1 To Ud - Ld + 1
　　　　　　d(i, 1) = y(Application.Match(Application.Small(x, i), x, 0))
　　　　Next i
　　　　Worksheets("sheet2").Range("C:C").ClearContents
　　　　Worksheets("sheet2").Range("C2").Resize(UBound(d), 1) = d

　　　　名前01 (Ud)　'　次の項で作成するコードを実行します。
End Sub

描画した机に名前を入れます。

Sub 名前01(ByVal n As Long)
　　Dim c As Range
　　Dim myShape As Shape
　　Dim i As Long
　　Dim myName() As String

　　With Worksheets("Sheet2")
　　　　'　nは座席数、Sheet2の名前を配列へ取り出す
　　　　ReDim myName(1 To n)
　　　　For i = 2 To n + 1
　　　　　　myName(.Range("C" & i).Value) = .Range("B" & i).Value
　　　　Next i
　　End With
　　' 　描画した座席(机)へ名前を入力する
　　With Worksheets("Sheet1")
　　　　For i = 1 To n
　　　　　　.Shapes("座席" & i).TextFrame.Characters.Text = myName(i)
　　　　Next i
　　End With
End Sub

実行後の画面です。

VBAの実行例　　　Topへ

コード「乱数01」を実行すれば、一瞬で名前が表示されます。
これでは面白みが無い・・・・ということで、「乱数01」を10回ほど繰り返すことで、名前が入れ替わる様子を見せるようにしてみました。
また実行時間を停止することで見えやすいようにしてみましたが、この辺は使用するPCに応じて適切に修正してください。

Sub 席替え()
　　Dim i As Long
　　Dim j As Long
　　Dim waitTime As Variant
　　For i = 1 To 10
　　　　waitTime = Now + TimeValue("0:00:01")
　　　　Application.Wait waitTime
　　　　乱数01
　　Next i
End Sub

スポンサードリンク

よねさんのWordとExcelの小部屋｜Excel(エクセル)講座の総目次｜Excel(エクセル) VBA入門：目次｜席替えを自動で行う

PageViewCounter
　 Counter
　Since2006/2/27

席替えを自動で行う:Excel VBA入門

はじめに Topへ

生徒のリストをSheet2へ作成する Topへ

座席(机)を描画する Topへ

乱数を作成し、Sheet2へ入力する Topへ

VBAの実行例 Topへ

はじめに　　　Topへ

生徒のリストをSheet2へ作成する　　　Topへ

座席(机)を描画する　　　Topへ

乱数を作成し、Sheet2へ入力する　　　Topへ

VBAの実行例　　　Topへ