尾牙賓果券程式

又是年終尾牙歡樂的時刻
今年公司福委會決定恢復往年玩賓果的遊戲
於是找上我寫一個產生賓果券的程式

用什麼寫呢? 當然是 Excel 囉 直接利用它的 CELL 當作賓果券的格子再適當也不過

公司這次希望每一個人有六個賓果遊戲券，每一個賓果券有 7 X 7  49 個號碼
以亂數產生，抽獎球1~88號

依照此需求我們先在 Excel VBA 中定義所需常數

Const maxball = 88 ' 最大號碼 Const matrix = 7     ' 方型矩陣UBound Const Nbr = 6         ' 幾個方型矩陣 Const rs = 3            ' 第一個方形矩陣開始 Cell 的 Row Const rc = 2            ' 第一個方形矩陣開始 Cell 的 Column Dim bingo(Nbr, matrix, matrix) As Integer ' 存放 BINGO 券號碼的三維陣列

有此定義後，開始撰寫主程式

iCount = 2 ' 主頁資料開始列   Do While Data.Cells(iCount, 1) <> "" ' 如果主頁資料為空白就停止讀取        sheetcount = sheetcount + 1  ' 為每一個資料列產生新的工作表       Worksheets("Template").Copy after:=Worksheets(sheetcount)   ' 透過 Template 產生新工作表       Set NewSheet = Sheets(sheetcount + 1)       NewSheet.Name = Data.Cells(iCount, 2)       NewSheet.Visible = True       NewSheet.Activate       NewSheet.Cells(2, 2) = "工號：" & Data.Cells(iCount, 1) & " 姓名：" & Data.Cells(iCount, 2)        Randomize    ' 對亂數產生器做初始化的動作。       For i = 1 To Nbr         DoEvents         For j = 1 To matrix           DoEvents           For k = 1 To matrix             DoEvents Continue:            seed = Int((maxball * Rnd) + 1)    ' 產生 1 到 maxball 之間的亂數值。             If Not CheckSeed(seed, i) Then  ' 檢查此亂數是否已出現過               GoTo Continue             End If             bingo(i, j, k) = seed   ' 將亂數值存到陣列中           Next k         Next j       Next i       For i = 1 To Nbr  ' 全部產生完畢後，將結果輸出         DoEvents         For j = 1 To matrix           DoEvents           For k = 1 To matrix             DoEvents             Select Case i               Case 1                 iRow = rs: iCol = rc               Case 2                 iRow = rs: iCol = rc + matrix + 1               Case 3                 iRow = rs + matrix + 1: iCol = rc               Case 4                 iRow = rs + matrix + 1: iCol = rc + matrix + 1               Case 5                 iRow = rs + 2 * matrix + 2: iCol = rc               Case 6                 iRow = rs + 2 * matrix + 2: iCol = rc + matrix + 1             End Select             NewSheet.Cells(iRow + (j - 1), iCol + (k - 1)) = bingo(i, j, k)           Next k         Next j       Next i       ResetBinGo       iCount = iCount + 1   Loop

引用Function

Private Sub ResetBinGo()   Dim i As Integer, j As Integer, k As Integer   For i = 1 To Nbr     For j = 1 To matrix       For k = 1 To matrix         bingo(i, j, k) = 0       Next k     Next j   Next i End Sub Private Function CheckSeed(n As Integer, i As Integer) As Boolean   Dim j As Integer, k As Integer   CheckSeed = True   For j = 1 To matrix     DoEvents     For k = 1 To matrix       DoEvents       If n = bingo(i, j, k) Then         CheckSeed = False       End If     Next k   Next j End Function

執行時，請記得將VBA安全性調到中度安全性，並且要啟用巨集

按產生賓果券，開始執行

大功告成，不過因為是一個Sheet一個Sheet產生，可能要注意Excel記憶體的問題(還沒正式測啦)