【Excel】ビンゴゲームを作る

 

このエクセルファイルの作り方

①ビンゴゲームのレイアウトを作成する

・A1:L16 ⇒ ビンゴの数字表示欄
・M2:Q16 ⇒ ビンゴで出た数字の背景色を緑色で表示
・「BINGO」ボタン ⇒ ルーレットを開始して「A1:L16」に数字を表示
・「Initialize」ボタン ⇒ 初期化
※各ボタン配置時に設定するマクロ名はそれぞれ「Bingo」、「Initialize」とする

②Microsoft Visual Basic for Applications」にて以下のコードを記載

Sub Bingo()
'結果
Dim result As Integer
'(これまでに出た)結果リスト
Dim resultList As Variant: resultList = Range("A21:A95")

'1~75まで全て出ている場合はなにもしない
If (IsEmpty(Range("A95").Value) = False) Then
GoTo PROCESSINGEXIT
End If

'ボタンを配置したセルを選択する
Cells(1, 13).Select

'フォントサイズを設定
Worksheets("BINGO").Range("A2").Font.Size = 350

'ルーレット表示
For i = 1 To 100
Application.Wait [Now()] + 5 / 86400000
result = Int(75 * Rnd + 1)
Worksheets("BINGO").Range("A2").Value = result
Next

'重複制御
Do While (1)
result = Int(75 * Rnd + 1)
For i = 1 To UBound(resultList)
If (resultList(i, 1) = result) Then
GoTo BREAK
End If
Next
Exit Do
BREAK:
Loop
Worksheets("BINGO").Range("A2").Value = result

'結果書き込み
For i = 1 To UBound(resultList)
If (IsEmpty(Cells(i + 20, 1).Value) = True) Then
Cells(i + 20, 1).Value = result
Exit For
Else
GoTo CONTINUE
End If
CONTINUE:
Next

PROCESSINGEXIT:

End Sub
Sub Initialize()
Range("A21:A95").ClearContents<img src="https://exceldemon.net/wp-content/uploads/2018/11/条件付き書式.png" alt="" width="379" height="396" class="alignnone size-full wp-image-432" />
Worksheets("BINGO").Range("A2").Font.Size = 15
Worksheets("BINGO").Range("A2").Value = "Please press ""BINGO"" button"
End Sub

③条件付き書式を設定

※すでに出た数値の背景色を緑色とする

プログラムの解説

'ルーレット表示
For i = 1 To 100
Application.Wait [Now()] + 5 / 86400000
result = Int(75 * Rnd + 1)
Worksheets("BINGO").Range("A2").Value = result
Next

100回ループさせ、「Application.Wait [Now()] + 5 / 86400000」の記載で5ミリ秒ごと1~75のランダムな数値を表示

'重複制御
Do While (1)
result = Int(75 * Rnd + 1)
For i = 1 To UBound(resultList)
If (resultList(i, 1) = result) Then
GoTo BREAK
End If
Next
Exit Do
BREAK:
Loop
Worksheets("BINGO").Range("A2").Value = result

「Do While (1)」で無限ループを発生。
「result = Int(75 * Rnd + 1)」でresultに1~75のランダムな数値を格納する。

「For i = 1 To UBound(resultList)~Next」でresultList分ループし、
resultListにresultの数値がすでに含まれている場合はBREAKして再度1~75のランダムな数値を格納し直す。
含まれていない数値だった場合は「Exit Do」でループを抜けて、「A2」にresultの数値をセット。

'結果書き込み
For i = 1 To UBound(resultList)
If (IsEmpty(Cells(i + 20, 1).Value) = True) Then
Cells(i + 20, 1).Value = result
Exit For
Else
GoTo CONTINUE
End If
CONTINUE:
Next

「For i = 1 To UBound(resultList)~Next」でresultList分ループし、
値が入っていないCellまで来たら今回Resultに格納している数値を書き込む

Sub Initialize()
Range("A21:A95").ClearContents
Worksheets("BINGO").Range("A2").Font.Size = 15
Worksheets("BINGO").Range("A2").Value = "Please press ""BINGO"" button"
End Sub

「Range(“A21:A95”).ClearContents」で背景色が緑色になったところを元に戻す。
初期のフォントサイズと初期値を設定。

【Excel】指定した数だけデータをコピーする

①コピー元シートを用意
※ここでは「表を複数の条件で絞り込む②」で作成したシートを使用(数量列だけ追加)

②ペーストするシートを用意

③コピーを実行するボタンを配置

④ボタン配置時の以下の画面で「マクロ名」を「CreateLabelData」として「新規作成」を押す

⑤「Microsoft Visual Basic for Applications」にて以下のコードを記載
※表の形式に応じて「★」のついた箇所の数値を変更

Sub CreateLabelData()
'コピー開始行
Dim copyStartRow As Integer: copyStartRow = 5 '★
'コピー最終行
Dim copyLastRow As Integer: copyLastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
'コピー開始列
Dim copyStartCol As Integer: copyStartCol = 2 '★
'コピー終了列
Dim copyLastCol As Integer: copyLastCol = 4 '★
'数量列
Dim quantityCol As Integer: quantityCol = 5 '★

'ペーストするシート名
Dim pasteSheetName As String: pasteSheetName = "商品ラベルデータ" '★
'ペースト行
Dim pasteRow As Integer: pasteRow = 2 '★
'ペースト列
Dim pasteCol As Integer: pasteCol = 1 '★
'ペーストするシートの最終行
pasteLastRow = Worksheets(pasteSheetName).UsedRange.Row + Worksheets(pasteSheetName).UsedRange.Rows.Count - 1

'ペーストするシートの初期化
For i = pasteRow To pasteLastRow Step 1
Worksheets(pasteSheetName).Rows(pasteRow).Delete
Next

'コピー開始行から終了行までループ
For i = copyStartRow To copyLastRow Step 1
'数量の指定が不正な場合は次の行へ
If Cells(i, quantityCol).Formula = "" Or IsNumeric(Cells(i, quantityCol).Value) = False Or Cells(i, quantityCol).Value < 1 Then
GoTo Continue
Else
End If

'対象行の数量を取得
Dim quantity As Integer: quantity = Cells(i, quantityCol).Value

'数量分コピー&ペーストを行う
For j = pasteRow To pasteRow + quantity - 1 Step 1
Range(Cells(i, copyStartCol), Cells(i, copyLastCol)).Copy Destination:=Worksheets(pasteSheetName).Cells(j, pasteCol)
Next

'次回ペースト行の更新
pasteRow = pasteRow + quantity

'数量の値を初期化
Cells(i, quantityCol).Value = ""
Continue:
Next

'ペーストしたシートを選択
Worksheets(pasteSheetName).Select
Worksheets(pasteSheetName).Cells(1, 1).Select
End Sub

【Excel】各シートの値を集計する

①マクロを使えるようにする
マクロを使えるようにする」を参照

②集計表のタイトルを用意

③集計するシートを用意

④集計用ボタンを配置

⑤ボタン配置時の以下の画面で「マクロ名」を「Aggregate」として「新規作成」を押す

⑥「Microsoft Visual Basic for Applications」にて以下のコードを記載
※★の部分を作成するレイアウトに合わせて修正

Sub Aggregate()
Dim sheet As Worksheet
'「集計」シートのシート名
Dim aggregateSheetName As String: aggregateSheetName = "集計" '★
'「集計」シートで大学名を表示する列
Dim collegeNameCol As Integer: collegeNameCol = 2 '★
'開始行
Dim startRow As Integer: startRow = 3 '★
'最終行
Dim lastRow As Integer: lastRow = Sheets(aggregateSheetName).Cells(Rows.Count, collegeNameCol).End(xlUp).Row + 1
'各シートで大学名が記載されたCell
Dim collegeNameCell As String: collegeNameCell = "A4" '★

'一旦行をすべてクリア
For i = startRow To lastRow - 1 Step 1
Rows(3).Delete
Next

'全てのシート分繰り返し処理
For Each sheet In Sheets
'「集計」シートの場合は何もしないで次のシートへ
If sheet.Name = aggregateSheetName Then
GoTo CONTINUE
End If

'最終行の再取得
lastRow = Sheets(aggregateSheetName).Cells(Rows.Count, collegeNameCol).End(xlUp).Row + 1

'各シートの大学名が記載されたCellの値を取得
Dim collegeName As String: collegeName = sheet.Range(collegeNameCell).Value

'「集計」シートのB列を3行目から最終行まで走査
For i = startRow To lastRow - 1 Step 1
'一致する行がある場合はC列に1を加算
If Cells(i, collegeNameCol).Value = collegeName Then
Cells(i, collegeNameCol + 1).Value = Cells(i, collegeNameCol + 1).Value + 1
'次のシートへ
GoTo CONTINUE
End If
Next

'最終行まで一致する行がなかった場合
If i = lastRow Then
'最終行のB列に大学名を代入
Cells(i, collegeNameCol).Value = collegeName
'C列に1を加算
Cells(i, collegeNameCol + 1).Value = Cells(i, collegeNameCol + 1).Value + 1
'罫線を引く
Cells(i, collegeNameCol).Borders.LineStyle = xlContinuous
Cells(i, collegeNameCol + 1).Borders.LineStyle = xlContinuous
End If
CONTINUE:
Next
End Sub

⑦「集計」ボタンを押すと各シートの値が集計される

【Excel】足し算の問題を作る

①UserFormの作成

②各ボタン押下時の処理を記載
※例外処理は省略

○「出題!」ボタン押下時のソース

Private Sub CommandButton1_Click()
'「出題!」ボタン押下時の処理

'一つ目のラベルに乱数をセット(1~9)
Label1.Caption = Str(Int(9 * Rnd + 1))

'二つ目のラベルに乱数をセット(1~9)
Label2.Caption = Str(Int(9 * Rnd + 1))

'回答入力欄にフォーカスセット
TextBox1.SetFocus

'正解判定ラベルを空に
Label3.Caption = ""

End Sub<span data-mce-type="bookmark" style="display: inline-block; width: 0px; overflow: hidden; line-height: 0;" class="mce_SELRES_start"></span>

○「採点!」ボタン押下時のソース

Private Sub CommandButton2_Click()
'「採点!」ボタン押下時の処理

'正解なら「〇」不正解なら「×」を表示
If (Val(Label1.Caption) + Val(Label2.Caption) = TextBox1.Text) Then
Label3.Caption = "○"
Else
Label3.Caption = "×"
End If

End Sub

【Excel】Excelファイルと同階層の最新フォルダを開く

①マクロを使えるようにする
マクロを使えるようにする」を参照

②FileSystemObjectを利用するため、「Microsoft Scripting Runtime」を参照
ライブラリの参照方法は「ライブラリを参照する」を参照

③必要に応じてボタン配置
ボタンの配置方法は「表を複数の条件で絞り込む②」を参照

④Microsoft Visual Basic for Applications」にて以下のコードを記載

Sub ボタン1_Click()
Dim fso As FileSystemObject
Set fso = New FileSystemObject

'Excelファイルが配置されているフォルダを取得
Dim pfl As Folder
Set pfl = fso.GetFolder(ActiveWorkbook.Path)

'Excelファイルと同じ階層にフォルダがなければ処理を終了
If pfl.SubFolders.Count = 0 Then
Set fso = Nothing
Exit Sub
End If

'最終的に開くフォルダ
Dim ofl As Folder
'日付を確認するために一時的に取得するフォルダ
Dim tfl As Folder

'サブフォルダ分日付を検証
For Each tfl In pfl.SubFolders
'初回のみoflに代入
If ofl Is Nothing Then
Set ofl = tfl
End If

'tflの更新日付がoflよりも大きければoflに代入(作成日時で比較の場合は「DateCreated」を使用)
If ofl.DateLastModified < tfl.DateLastModified Then
Set ofl = tfl
End If
Next

'一番更新日付が大きいoflを起動
Shell "C:\Windows\explorer.exe " & ofl.Path, vbNormalFocus
End Sub