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

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