席替えをくじ引きで行う:Excel VBA入門

スポンサードリンク

はじめに　　　Topへ

乱数を使用して自動で行う方法は席替えを自動で行う　を参照してください。
ここでは、"くじ引き風"の方法で席替えを実行しようと思います。
サンプルはこちらからダウンロードできます。→　HP2010_sekigae.xlsm(Excel2010のマクロ付ファイル：約50KB)

くじを作成する　　　Topへ

「くじ引き」風にするため、オートシェイプをSheet3へ描画します。
このオートシェイプは乱数を付けた名前にします。
各オートシェイプには「席1」～「席40」の名前がランダムに付けてあります。
- 数式バーの名前ボックスではオートシェイプの名前が表示されるので、実行時には非表示にしています。
  - 下図の選択しているオートシェイプの名前「席16」の「16」が乱数で作成したものです。
    ですので、この時点でどこの席かは決まっています。左上隅から16番目の席を引いていることになります。

コードの例

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

Sub seat02()
　　Dim c As Range
　　Dim myShape As Shape
　　Dim n As Long
　　Dim ob As Object
　　'数式バーを非表示にします
　　Application.DisplayFormulaBar = False

　　'乱数発生
　　　　Dim i As Long
　　　　Dim x()
　　　　Dim y()
　　　　Dim d
　　　　'---開始値Ldと終了値Udを定数で指定
　　　　Const Ld = 1
　　　　Const Ud = 40　' 生徒数40としていますので、ここを適切な数値に変更します。
　　　　'----使用する配列を準備する
　　　　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
　　'ここまで

　　'　nで座席数を指定
　　　n = Ud

　　　With Worksheets("Sheet3")

　　　For Each ob In .DrawingObjects
　　　　　If Not Intersect(ob.TopLeftCell, .Range("B1:G20")) Is Nothing Then
　　　　　　　ob.Delete
　　　　　End If
　　　Next

　　　.Rows("2:10").RowHeight = 35
　　　.Columns("B:G").ColumnWidth = 15
　　　i = 0
　　　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 = "席" & d(i, 1)
　　　Next c

　　　.Range("A1").Select
　　End With
End Sub

席を移動する　　　Topへ

このシートを表示した状態で、生徒にオートシェイプに自分の名前を入力してもらいます。
下図は名前1～名前40を入力してもらった状態です。

テストで名前を入力するのが面倒ですので・・・こんな感じで名前を入力したと仮定します。

Sub 仮名を入力()
　　Dim ob As Shape
　　Dim i As Integer
　　　　i = 0
　　　　For Each ob In Worksheets("Sheet3").Shapes
　　　　　　If Left(ob.Name, 1) = "席" Then
　　　　　　　　i = i + 1
　　　　　　　　ob.TextFrame.Characters.Text = "名前" & i
　　　　　　End If
　　　　Next ob
End Sub

左上隅から横へ「名前1」から「名前40」までナンバリングしています。
(説明用に最初の状態から異動後の状態をわかりやすくするためです）

オートシェイプにつけてあった名前順にオートシェイプを並べ替えます。

一瞬で終わりますのであまり面白みがない・・・・かもしれません。

Sub 配置()
　　Dim c As Range
　　Dim i As Long
　　　　'　数式バーが非表示名なっているので表示します。　
　　　　Application.DisplayFormulaBar = True
　　　　' オートシェイプを並べ替えます。
　　　　For Each c In Worksheets("Sheet3").Range("B2:G8")
　　　　　　i = i + 1
　　　　　　'エラー回避のため人数分を超えるとループから抜ける
　　　　　　If i > 40 Then Exit For
　　　　　　With Worksheets("Sheet3").Shapes("席" & i)
　　　　　　　　　.Left = c.Left
　　　　　　　　　.Top = c.Top
　　　　　　End With
　　　　Next c
End Sub

実行後の画面です。

席を移動する（その2）　　　Topへ

くじの結果を表示するのをB12セル以降にして、1つの席ごとに表示してみます。

コードの例

Sub 配置2()
　　Dim c As Range
　　Dim i As Long
　　Dim waitTime As Variant
　　　　Application.DisplayFormulaBar = True
　　　　For Each c In Worksheets("Sheet3").Range("B12:G18")
　　　　　　i = i + 1
　　　　　　'エラー回避のため人数分を超えるとループから抜ける
　　　　　　If i > 40 Then Exit For
　　　　　　'実行を一時停止して1つずつ移動する
　　　　　　waitTime = Now + TimeValue("0:00:01")
　　　　　　Application.Wait waitTime

　　　　　　With Worksheets("Sheet3").Shapes("席" & i)
　　　　　　　　　　.Left = c.Left
　　　　　　　　　　.Top = c.Top
　　　　　　End With
　　　　Next c
End Sub

実行中の様子
- オートシェイプの名前が「席1」から順番にB12セルへ移動している様子です。
最終結果

スポンサードリンク

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

PageViewCounter
　 Counter
　Since2006/2/27

席替えをくじ引きで行う:Excel VBA入門

はじめに Topへ

くじを作成する Topへ

席を移動する Topへ

席を移動する（その2） Topへ

はじめに　　　Topへ

くじを作成する　　　Topへ

席を移動する　　　Topへ

席を移動する（その2）　　　Topへ