▲特定のセルからランダムに抽出しテストを作成▲

いつもお世話になっております。
エクセルのVBAについて教えて頂きたく書き込みいたします。
日本語が意味不明であれば、より詳しく記載しますのでご教授願います。

1つのエクセルの中に4つのシートがあります。
【Top(sheet1)、問題(sheet2)、初級(sheet3)、中級(sheet4)、上級(sheet5)】

Topにはスタートボタンがあり、クリックすることにより問題シートへと移動し、別シートより問題を抽出したいです。

問題シート内のC3～C17に問題が、D3～D17に(問題に付随した)ヒントが
ランダムに抽出されるようにマクロを作成したいです。

また問題、ヒント、答えは初級、中級、上級、それぞれのシートに(20問ずつぐらい)記載をしています。
初級から10問、中級から3問、上級から2問と抽出をしたいです。
答えに回答を入力することにより正解であればセルが青く、間違えであればセルが赤くなるようにしたいです。

簡易ではありますが、エクセルの画像も添付させてもらいます。
恐れ入りますがご教授願います。

No.2 ベストアンサー 回答者： tom04 回答日時： 2014/02/24 22:05

こんばんは！

面白そうなのでトライしてみました。

Sheet6を作業用のSheetとして追加・使用するようにしていますので、
Book上にはお示しの5つのSheetが存在しているという前提です。
尚、各Sheetともお示しの配置通りとします。

ます「TOP」Sheetにコマンドボタンを挿入　→　コマンドボタンのコードを↓にしてみてください。

Private Sub CommandButton1_Click()
Worksheets("問題").Select
Worksheets("問題").Range("E3:E17").Interior.ColorIndex = xlNone
Call Sample1
End Sub

次にAlt+F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてください。

Sub Sample1() 'この行から
Dim i As Long, lastRow As Long, c As Range
Dim wS2 As Worksheet, wS3 As Worksheet, wS4 As Worksheet, wS5 As Worksheet, wS6 As Worksheet
Set wS2 = Worksheets("問題")
Set wS3 = Worksheets("初級")
Set wS4 = Worksheets("中級")
Set wS5 = Worksheets("上級")
Application.ScreenUpdating = False
If Worksheets.Count <> 6 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
End If
Set wS6 = Worksheets(Worksheets.Count)
wS6.Visible = xlSheetHidden
wS6.Range("A:C").Clear
wS2.Range("C3:E17").ClearContents
With wS3
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
.Range("E:F").Insert
Range(.Cells(2, "E"), .Cells(lastRow, "E")).Formula = "=RAND()"
Range(.Cells(2, "F"), .Cells(lastRow, "F")).Formula = "=RANK(E2,E:E)"
For i = 1 To 10
Set c = .Range("F:F").Find(what:=i, LookIn:=xlValues, lookat:=xlWhole)
c.Offset(, -4).Resize(, 3).Copy
wS6.Activate
ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Next i
.Range("E:F").Delete
End With
With wS4
.Range("E:F").Insert
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
Range(.Cells(2, "E"), .Cells(lastRow, "E")).Formula = "=RAND()"
Range(.Cells(2, "F"), .Cells(lastRow, "F")).Formula = "=RANK(E2,E:E)"
For i = 1 To 3
Set c = .Range("F:F").Find(what:=i, LookIn:=xlValues, lookat:=xlWhole)
c.Offset(, -4).Resize(, 3).Copy
wS6.Activate
ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Next i
.Range("E:F").Delete
End With
With wS5
.Range("E:F").Insert
lastRow = .Cells(Rows.Count, "B").End(xlUp).Row
Range(.Cells(2, "E"), .Cells(lastRow, "E")).Formula = "=RAND()"
Range(.Cells(2, "F"), .Cells(lastRow, "F")).Formula = "=RANK(E2,E:E)"
For i = 1 To 2
Set c = .Range("F:F").Find(what:=i, LookIn:=xlValues, lookat:=xlWhole)
c.Offset(, -4).Resize(, 3).Copy
wS6.Activate
ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Next i
.Range("E:F").Delete
End With
wS6.Range("A2:B16").Copy
wS2.Activate
ActiveSheet.Range("C3").Select
Selection.PasteSpecial Paste:=xlPasteValues
wS2.Columns.AutoFit
wS2.Range("E3").Select
Application.ScreenUpdating = True
End Sub 'この行まで

最後に「問題」SheetのSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペースト　→　Excel画面に戻り「TOP」Sheetのコマンドボタンをクリックし
「問題」SheetのE列に答えを入力してみてください。

Private Sub Worksheet_Change(ByVal Target As Range) 'この行から
Dim c As Range
If Intersect(Target, Range("E3:E17")) Is Nothing Or Target.Count > 1 Then Exit Sub
With Worksheets(6)
If Target <> "" Then
Set c = .Range("A:A").Find(what:=Target.Offset(, -2), LookIn:=xlValues, lookat:=xlWhole)
If Target = c.Offset(, 2) Then
Target.Interior.ColorIndex = 8 '←水色
Else
Target.Interior.ColorIndex = 3
End If
Else
Target.Interior.ColorIndex = xlNone
End If
End With
End Sub 'この行まで

※　通常の青だと字が見えにくいので「水色」にしています。m(_ _)m

この回答へのお礼

興味を持って頂き、また色々と試して頂いたことと思います。
本当にありがとう御座います。

VBAをやりたいと思い3日ほどでぶち当たりました。
さすがにこれだけのコードは理解することができません。
これを参考に勉強していきたいと思います。

本当にありがとう御座います。

お礼日時：2014/02/25 21:37

No.3 回答者： optimumsoup 回答日時： 2014/02/24 22:07

次のマクロでしーと3,4,5から10,3,2問をシート2にランダム抽出します。

まだ未完成のところは乱数がダブったときの処置ができていないことです。


Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2014/2/23 ユーザー名 :
'

'
Dim ransu As Variant, i As Integer
For i = 4 To 13
Sheets("Sheet3").Select

ransu = Int(20 * Rnd + 3)

Cells(ransu, 3).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(i, 3).Select
ActiveSheet.Paste
Next
For i = 14 To 16
Sheets("Sheet4").Select

ransu = Int(20 * Rnd + 3)

Cells(ransu, 3).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(i, 3).Select
ActiveSheet.Paste
Next
For i = 17 To 18
Sheets("Sheet5").Select

ransu = Int(20 * Rnd + 3)

Cells(ransu, 3).Select
Selection.Copy
Sheets("Sheet2").Select
Cells(i, 3).Select
ActiveSheet.Paste
Next



End Sub

No.1 回答者： nac03056 回答日時： 2014/02/24 17:57

いろいろなやり方があるかと思うので、あくまで私流ということで。

面倒なので、問題番号１～１０は初級、１１～１３が中級、１４～１５が上級と決めます。

事前準備として、初級・中級・上級のＡ２からＡ２１までに計算式「 =rand() 」を入れておき乱数を表示させておきます。
シート１のスタートに、レコードマクロで記録開始。
初級のＡ２からＤ２１を範囲選択しＡ列をキーにソートします。（昇順降順どちらでも可。ご存知とは思いますが、先頭行を見出しにしないよう注意してください。１行目が動かず固定になってしまいます）
同様に中級・上級も並べ替え。
これでレコードマクロを終了します。
問題シートの計算式ですが、セルＣ３に「 =初級!B2 」をＤ３に「 =初級!C2 」を入れてそれらを１２行まで複写、同様にＣ１３に「 =中級!B2 」をＤ３に「 =中級!C2 」を入れてそれらを１５行まで複写、同様にＣ１６に「 =上級!B2 」をＤ３に「 =上級!C2 」を入れてそれらを１７行まで複写、これで問題作成は完成です。
採点に関しては条件付き書式が楽そうなので、あらかじめＥ３からＥ１７の文字色を赤色にしておき、セル値と回答のセルの値が一致したら青色に変える指定を行えばできあがりです。（画像を比べると私のとはエクセルのバージョンが違うようなので、条件付き書式の扱い方がわからないようなら聞いて下さい）

もし、問題を初級から並べるのではなくバラバラにということであれば、並べ替え後に初級～上級から問題シートに正解もコピーしておき、ソートでのシャッフルと同様にここで混ぜてあげれば可能です。
目の前で説明すれば１０分程度の話なんですが、意味は伝わりましたでしょうか。
うまく動くことをお祈りいたします。

この回答へのお礼

お答えありがとう御座いましたっ！
試してみたのですが、不明点が多く出来ませんでした。
No2さんのコードで上手くできました！ありがとう御座います。

お礼日時：2014/02/25 21:35