ルールテストを作成

referee

某審査会のためのルールテストを作成しました。例年は2日間で実施している本審査会ですが、今年はなんと3日間開催。
各日で別のルールテストを用意しないといけないんですが、手動じゃ面倒なのでエクセルVBAでマクロを作成しました。

すでに問題文は50個用意されていて、ここからランダムに25個を選択する。
さて、つくったマクロのルーチンはこんな感じ。

  1. 1〜50までの整数が入った配列を作成する。
  2. その配列をシャッフルする。
  3. 配列の数字をA列へ上から25個入れる。
  4. VLOOKUPで例題が入っているシートから問題をコピー
  5. 体裁(フォント指定とか、罫線とか)を整える。)

作ってから反省したんですが、例題の入っているシートはすでに罫線もフォント指定もされているので、
VLOOKUPじゃなくて、Cells(1,n)→nはシャッフルした数字で25個別シートへコピーすればよかったかなと。

まぁこれで3日分の問題が3クリックで作成できました。マクロでやるのと手動で3日分つくるのとではおそらく後者の方が時間的には有利なんでしょうが、まぁそこは技術職のこだわりというかなんというか。
マクロのソースはこんなです。

Sub Macro1()
'
' Macro1 Macro
'

'
Dim SheetsName As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim MondaiNumber(50) As Integer

    Sheets.Add After:=Sheets(Sheets.Count)  'シートを追加する
    SheetName = ActiveSheet.Name            'シートの名前を取得

    For i = 1 To 50                         '1〜50の数字を配列へ投入する
        MondaiNumber(i) = i
    Next

    For i = 1 To 50                         'シャッフルする
        j = Int(Rnd() * 50) + 1
        k = MondaiNumber(i)
        MondaiNumber(i) = MondaiNumber(j)
        MondaiNumber(j) = k
    Next

    Sheets("例題").Rows("1:10").Copy  'タイトルをコピー
    Rows(1).PasteSpecial

    For i = 1 To 25         '1〜25の数字をA列へ入れる。その後VLOOKUPで例題から問題と回答をコピーする。
        Cells(10 + i, 1).Value = MondaiNumber(i)
        Cells(10 + i, 2).Value = WorksheetFunction.VLookup(MondaiNumber(i), Sheets("例題").Range("A11:K110"), 2, False)
        Cells(10 + i, 11).Value = WorksheetFunction.VLookup(MondaiNumber(i), Sheets("例題").Range("A11:K110"), 11, False)
    Next

    Range("A11:K35").Sort Key1:=Range("A11"), Order1:=xlAscending       '問題番号でソートする
    Range("A11:K35").RowHeight = 60                                     '行の高さ調整
    Range("A11:A35").HorizontalAlignment = xlCenter                     '問題番号と回答の○×を中央揃え
    Range("A11:A35").VerticalAlignment = xlCenter
    Range("K11:K35").HorizontalAlignment = xlCenter
    Range("K11:K35").VerticalAlignment = xlCenter
    Range("B11:J35").Merge Across:=True                                 '問題文のところセルをマージする
    Range("A11:K35").Font.Name = "HG丸ゴシックM-PRO"                       'フォント
    Range("A11:K35").Font.Size = 12                                     'フォントサイズ
    Range("A11:K35").WrapText = True                                    '折り返して表示
    Range("A11:K35").Borders.LineStyle = True                           '罫線

    For i = 1 To 25                                                     '問題番号をリナンバー
        Cells(10 + i, 1) = i
    Next

    Worksheets(SheetName).Copy After:=Sheets(Sheets.Count)              '別のシートへコピーして
    Range("K11:K35").ClearContents                                      '回答をクリアする
End Sub


    

    <