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

Question

エクセルのVBAについて教えて頂きたく書き込みいたします。

日本語が意味不明であれば、より詳しく記載しますのでご教授願います。

1つのエクセルの中に4つのシートがあります。

【Top(sheet1)、問題(sheet2)、初級(sheet3)、中級(sheet4)、上級(sheet5)】

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

問題シート内のC3～C17に問題が、D3～D17に(問題に付随した)ヒントが、E3～E17に回答が

それらをランダムに抽出されるようにマクロを作成したいです。回答は表示させたくないです。

また問題、ヒント、答えは初級、中級、上級、それぞれのシートに(20問ずつぐらい)記載をしています。

初級から10問、中級から3問、上級から2問と抽出をしたいです。

答えに回答を入力することにより正解であればセルが青く、間違えであればセルが赤くなるようにしたいです。

簡易な説明ではありますがご教授願います。

Answer 1

まあ、下を出すと、全部書いちゃってるようなものなので、その代りと言ってはなんですが、詳細な解説はしません。

前提はSheet1のC3：E17に15題の問題、ヒント、答えがあると言う状態で、実行すると

Sheet2のC1 から3行問題とヒントが表示されます。

E列には条件付き書式を設定し、何かいれると答えと一致しているかどうかチェックして反応する仕掛けです。

大まかな動きとしては、配列に重複しない１～15の数値を3個入れ、それを頼りに問題をコピーします。

Sub aaa()

Dim wAry(2), wNO As Long

Dim I As Long, J As Long, wFlg As Boolean

Dim wSht As Worksheet, wAns As Range, wCondition As FormatCondition

Set wSht = Worksheets("Sheet2")

For I = 0 To 2

  wFlg = True

  Do While wFlg

    wFlg = False

    wNO = Int(Rnd() * 15) + 1

    For J = 0 To I - 1

      If wAry(J) = wNO Then

        wFlg = True

        Exit For

      End If

    Next

  Loop

  wAry(I) = wNO

Next

With Worksheets("Sheet1")

For I = 0 To 2

  .Cells(2 + wAry(I), 3).Resize(1, 2).Copy Destination:=wSht.Cells(I + 1, 1)

  Set wAns = .Cells(2 + wAry(I), 5)

  With wSht.Cells(I + 1, 3)

    .FormatConditions.Delete

    Set wCondition = .FormatConditions.Add(Type:=xlExpression, Formula1:="=AND(" & .Address & "<>""""," _

                                                  & .Address & "=" & wAns.Parent.Name & "!" & wAns.Address & ")")

    With wCondition.Interior

      .PatternColorIndex = xlAutomatic

      .Color = &HFF0000

    End With

    Set wCondition = .FormatConditions.Add(Type:=xlExpression, Formula1:="=AND(" & .Address & "<>""""," _

                                                  & .Address & "<>" & wAns.Parent.Name & "!" & wAns.Address & ")")

    With wCondition.Interior

      .PatternColorIndex = xlAutomatic

      .Color = &HFF

    End With

  End With

Next

End With

End Sub

書き流しであまり良いコードではありませんが、参考まで。

Answer 2

不躾な質問で失礼しました。

コードを一度記載させて頂きます。

今ぶつかっているのが、ランダムに引っ張ることは出来るのですが

問題が重複してしまいます。

もしよければご教授願います。

スタートボタン

Private Sub CommandButton1_Click()

Worksheets("問題").Select

Worksheets("問題").Range("E3:E17").Interior.ColorIndex = xlNone

Call Sample1

End Sub

Generalに下記

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

worksheetに書き

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

以上になります。

Answer 3

y sakuda さん、いつもアドバイスありがとうございます。

宮内英行 さん、こんにちは。

マイクロソフト コミュニティをご利用いただき、ありがとうございます。

特定のセルから、ランダムにデータを抽出するようなマクロを作成したいということですね。

お手元で VBA で作成して試してみたコードなどはあるでしょうか ?

作成コードがある場合は、こちらのスレッドに質問されたい点とあわせて書き込んでみると、アドバイスや回答も得られやすくなると思いますよ。

また、ほかにも専門の VBA フォーラムもあるので、こちらのフォーラムにも投稿し、情報を集めてみるのも良いと思います。

・ Visual Basic for Application (VBA)

よろしければ活用なさってみてくださいね。

Answer 4

何処が分からないのでしょうか？

もし、VBAがそれなりに使えればもっと具体的に記述できると思うのですが・・・・

もし、VBAを全くご存じないか、マクロ記録しかできないということであれば、一度VBAの入門書を購入して勉強してください。

それからVBAの質問の場合、問題となっている部分のコードを提示してください。

（それで問題の所在や、VBAをどの程度使われるのかレベルが大体読めます）

もし、全くVBAをご存知でなく、丸ごと教えろというのでしたら、こういう所は筋違いです。無料のコード提供所ではありませんし、教科書替わりでもありません。