請問如何用ARRAY做資料比對？

看了一些VBA的教學，看得半懂不懂。還是自己動手寫一些VBA的小程式，抽學得比較快。
最近嘗試用VBA寫BINGO遊戲，造數字卡的部份和抽號碼的部份都能成功，可是用VBA對號碼的部份我卻不了解。
由於BINGO遊戲只要是：直、橫、對角線成一線便可以勝出。以5X5的數字卡為例，是否我需要寫下
5橫、5直、2對角，共12個組合的IF CONDITION才能做比對？
曾問過同事，他建議我可以用ARRAY的方法做，包括抽號碼和造數字卡也可以。
我大概也試過ARRAY，先把隨機數字放在ARRAY中，再順序抽出，但我無法避免重複數字。

所以我想請教大家，小弟的DRAW和PAPER的程序可以用ARRAY改寫嗎？
另外，如何在抽一個新的號碼時比對數字卡，看看是否中獎，謝謝大家。

bango.rar (14.37 KB)

樓主熱帖

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2011-12-16 17:52 | 只看該作者

本帖最後由 GBKEE 於 2011-12-16 17:53 編輯

回復 1# 小俠客

Option Explicit
Public Rng As Range, Rng1 As Range, Rng2 As Range
Sub Restart()
Sheets(1).Cells.Clear
End Sub
Sub Draw()
Dim B As Integer, C As Integer, d As Integer
With Sheet1
L:
B = Int(100 * Rnd() + 1)
C = Application.CountIf(.Range("A:A"), B) '比對是否重復
If C = 1 Then GoTo L: '重做亂數
d = Application.CountA(.Range("A:A")) + 5
.Cells(d, 1) = B
.Cells(d, 1).Select
Bingo (B)
End With
End Sub
Sub Paper()
Dim E As Range, B As Integer, i As Integer, ii As Integer
Set Rng = [Sheet1!I1:M5] '設定數字區域
For Each E In Rng
L:
B = Int(100 * Rnd() + 1)
C = Application.CountIf(Rng, B) '比對是否重復
If C = 1 Then GoTo L:
E = B
Next
For i = 1 To 5 '設定對角線由左至右區域
If i = 1 Then
Set Rng1 = Rng.Cells(i, i)
Else
Set Rng1 = Union(Rng1, Rng.Cells(i, i))
End If
Next
ii = 5
For i = 1 To 5 '設定對角線由右至左區域
If i = 1 Then
Set Rng2 = Rng.Cells(i, ii)
Else
Set Rng2 = Union(Rng1, Rng.Cells(i, ii))
End If
ii = ii - 1
Next
End Sub
Sub Bingo(No As Integer)
Dim f As Range, d As Integer, C As Range, i As Integer, ii As Integer
Set f = Rng.Find(No, LookIn:=xlValues, LOOKAT:=xlWhole) '尋找數字
If f Is Nothing Then Exit Sub
If Not f Is Nothing Then
f.Font.ColorIndex = 3 '找到數字給字體顏色
f.Font.FontStyle = "粗體" '找到數字給字型樣式
End If
For i = 1 To Rng.Columns.Count
d = 0
For Each C In Rng.Columns(i).Cells
If C.Font.ColorIndex = 3 Then d = d + 1
Next
If d = 5 Then Rng.Columns(i).Select: GoTo ok
Next
For i = 1 To Rng.Rows.Count '檢查橫列
d = 0
For Each C In Rng.Rows(i).Cells
If C.Font.ColorIndex = 3 Then d = d + 1
Next
If d = 5 Then Rng.Rows(i).Select: GoTo ok
Next
d = 0
For Each C In Rng1 '檢查對角線
If C.Font.ColorIndex = 3 Then d = d + 1
Next
If d = 5 Then Rng1.Select: GoTo ok
d = 0
For Each C In Rng2 '檢查對角線
If C.Font.ColorIndex = 3 Then d = d + 1
Next
If d = 5 Then Rng2.Select: GoTo ok
Exit Sub
ok:
MsgBox "Bingo"
End Sub

複製代碼

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 267
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2025-10-31

2024年全勤獎章 2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章