【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】同率(順位重複)を考慮したランキング表

①アンケート表、集計表を作成

②アンケート表に総数行を用意
「=COUNTA(C3:C20)」と入力してG列までコピー

③アンケート表に順位行を用意
「=RANK.EQ(C21,$C$21:$G$21)」と入力してG列までコピー

④アンケート表に順位(一意)行を用意
「=IF(COUNTIF($A$23:B23,C22)>0,C22 + 1,C22)」と入力してG列までコピー
※重複を回避するため、現在地より左ですでに同じ値がある場合は+1をする

⑤集計表に順位(一意)列を用意

⑥順位(一意)を元に集計表の順位を表示
「=INDEX($C$22:$G$22,MATCH(A27,$C$23:$G$23, 0))」と入力して31行目までコピー

⑦順位(一意)を元に集計表に旅行先を表示
「=INDEX($C$2:$G$2,MATCH(A27,$C$23:$G$23,0))」と入力して31行目までコピー

⑧不要行・列を非表示

【Excel】インクリメントしたシート名を追加する

Sub Test()
Dim resultSheetName As String: resultSheetName = "テスト結果" '基本となるシート名
Dim newSheetName As String: newSheetName = resultSheetName '動的に変化するシート名
Dim count As Integer: count = 1

Dim ws As Worksheet
'全てのシートを走査し、同じシート名が存在する場合はcountを加算してnewSheetNameを更新
For Each ws In Worksheets
If ws.Name = newSheetName Then
count = count + 1
newSheetName = resultSheetName & "(" & CStr(count) & ")"
End If
Next ws

'シート追加及び名称変更
Dim newWorksheet As Worksheet: Set newWorksheet _
= Worksheets.Add(After:=Sheets(Worksheets.count))
newWorksheet.Name = newSheetName

'Testシートに戻る
Sheets("Test").Select
End Sub

【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