コピペで作れるExcelVBAのビンゴゲーム

2026/02/23
MS Office
Excel, VBA

年末に必要になったので作りました。せっかくなのでシェアします。システムだけです。ビンゴカードは別途ご用意ください（100均などで購入できます）。

こんなかんじ

「抽選」ボタンを押すと1～75までの番号をランダムに取得し、左上の大きなセルに表示します。そのとき、お好きなmp3ファイルを再生できます。「ジャン！」みたいな音を出すとそれっぽいです。「抽選」ボタンを押すごとに右側に格納されていきます。

75個の数字が出揃うと以下のような形で、「リセット」ボタンを押すと表示が消え、初期状態に戻ります。

シートの準備

「メイン」「設定」の2つのシートが必要です。「設定」シートは、挿入して名前だけ変えればOKです。（「設定」シートは、A列に1～75までの番号がセットされて、番号を抽選する用に使います。）

「メイン」シートには、以下のものを作ります。セルの位置は好きなように変えていただけますが、変えた場合はコードのほうも一緒に変えてください。色や罫線、文字の大きさはマクロで変更しませんので、手動でお好みの形へ設定してください。

表示セル　…　A2:A6 の結合セル
格納セル　…　C2セルを起点（左上）にした 9×9セルの範囲

コード

標準モジュールを作って、以下をコピペしてください。「抽選」ボタンへ「start」プロシージャを、「リセット」ボタンへ「reset」プロシージャを割り当てます。ボタンの作成とプロシージャ割り当てはこちらの記事もご覧ください。

上部のハイライト部分で、シート名やセルの範囲を作成したものへ合わせてください。mp3ファイルは、フルパス内に空白が含まれないように注意してください。

'==========================================
'メインシート
Const MAIN_NAME As String = "メイン" 'メインシート名
Const SHOW_CELL As String = "A2:A6" '表示セル
Const STOCK_CELL As String = "C2" '格納セルの起点（左上セル）
'設定シート
Const SETTING_NAME As String = "設定" '設定シート名
'効果音
Const MP3_PATH As String = "C:\bingoSE.mp3" 'MP3ファイルのフルパス
'==========================================

Option Explicit
Option Base 1

'音を再生するための設定
#If Win64 Then
  Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
   (ByVal lpstrCommand As String, _
    ByVal lpstrReturnString As String, _
    ByVal uReturnLength As Long, _
    ByVal hwndCallback As Long) _
  As Long
#Else
  Private Declare Function mciSendString Lib "winmm" Alias "mciSendStringA" _
    (ByVal lpstrCommand As String, _
     ByVal lpstrReturnString As String, _
     ByVal uReturnLength As Long, _
     ByVal hwndCallback As Long) _
  As Long
#End If

Sub start() '抽選ボタンへ割付
  Dim st_main As Worksheet: Set st_main = Sheets(MAIN_NAME) 'メインシート
  Dim showCell As Range: Set showCell = st_main.Range(SHOW_CELL) '表示セル
  Dim stockCell As Range: Set stockCell = st_main.Range(STOCK_CELL) '格納セル
  Dim st_setting As Worksheet: Set st_setting = Sheets(SETTING_NAME) '設定シート
    
  '番号確認
  If st_setting.Range("A1").Value = "" Then
    If MsgBox("抽選番号がありません。リセットしますか？", vbOKCancel, "確認") = vbOK Then
      Call reset 'リセット
    End If
    Exit Sub
  End If
  
  '表示セルから格納セルへ転記
  Dim row As Long, col As Long
  If showCell.Cells(1, 1).Value <> "" Then '表示セルが空じゃなかったら
    '最終行を取得
    For row = 8 To 0 Step -1
      If stockCell.Offset(row, 8).Value <> "" Then Exit For
    Next row
    row = row + 1
    
    '最終列を取得
    For col = 8 To 0 Step -1
      If stockCell.Offset(row, col).Value <> "" Then Exit For
    Next col
    col = col + 1
    
    stockCell.Offset(row, col).Value = showCell.Cells(1, 1).Value '表示セルから格納セルへ転記
    showCell.ClearContents '表示セルクリア
  End If
  
  '抽選
  Dim lastRow As Long: lastRow = st_setting.Cells(Rows.Count, 1).End(xlUp).row '設定シートでデータが存在する行番号の最後を取得
  Randomize '乱数取得
  Dim i As Long: i = Int(lastRow * Rnd) + 1 '行番号をランダムに取得
  
  Call mciSendString("play " & MP3_PATH, "", 0, 0) '音を再生
    
  showCell.Cells(1, 1).Value = st_setting.Cells(i, 1).Value '表示セルへ抽選番号を転記
  st_setting.Cells(i, 1).Delete Shift:=xlUp '抽選番号を削除
End Sub

Sub reset() 'リセットボタンへ割付
  Dim st_main As Worksheet: Set st_main = Sheets(MAIN_NAME) 'メインシート
  Dim showCell As Range: Set showCell = st_main.Range(SHOW_CELL) '表示セル
  Dim stockCell As Range: Set stockCell = st_main.Range(STOCK_CELL) '格納セル
  Dim st_setting As Worksheet: Set st_setting = Sheets(SETTING_NAME) '設定シート
  
  st_setting.Columns("A").ClearContents '抽選番号クリア
  
  '1～75まで入力
  Dim i As Long
  For i = 1 To 75
    st_setting.Cells(i, 1) = i
  Next i
  
  showCell.ClearContents '表示セルクリア
  Range(stockCell, stockCell.Offset(8, 8)).ClearContents '格納セルクリア
End Sub