尾牙賓果券程式

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

用什麼寫呢? 當然是 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安全性調到中度安全性,並且要啟用巨集

image

按產生賓果券,開始執行

新圖片 (9)

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

 新圖片 (10)

張貼留言