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

小俠客

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

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

GBKEE

回復 1# 小俠客

1. Option Explicit
   
2. Public Rng As Range, Rng1 As Range, Rng2 As Range
   
3. Sub Restart()
   
4.     Sheets(1).Cells.Clear
   
5. End Sub
   
6. Sub Draw()
   
7.     Dim B As Integer, C As Integer, d As Integer
   
8.     With Sheet1
   
9. L:
   
10.         B = Int(100 * Rnd() + 1)
    
11.         C = Application.CountIf(.Range("A:A"), B)       '比對是否重復
    
12.         If C = 1 Then GoTo L:                           '重做亂數
    
13.         d = Application.CountA(.Range("A:A")) + 5
    
14.         .Cells(d, 1) = B
    
15.         .Cells(d, 1).Select
    
16.         Bingo (B)
    
17.     End With
    
18. End Sub
    
19. Sub Paper()
    
20.     Dim E As Range, B As Integer, i As Integer, ii As Integer
    
21.     Set Rng = [Sheet1!I1:M5]                  '設定數字區域
    
22.     For Each E In Rng
    
23. L:
    
24.         B = Int(100 * Rnd() + 1)
    
25.         C = Application.CountIf(Rng, B)        '比對是否重復
    
26.         If C = 1 Then GoTo L:
    
27.             E = B
    
28.     Next
    
29.     For i = 1 To 5                             '設定對角線由左至右區域
    
30.         If i = 1 Then
    
31.             Set Rng1 = Rng.Cells(i, i)
    
32.         Else
    
33.             Set Rng1 = Union(Rng1, Rng.Cells(i, i))
    
34.         End If
    
35.     Next
    
36.     ii = 5
    
37.     For i = 1 To 5                             '設定對角線由右至左區域
    
38.         If i = 1 Then
    
39.             Set Rng2 = Rng.Cells(i, ii)
    
40.         Else
    
41.             Set Rng2 = Union(Rng1, Rng.Cells(i, ii))
    
42.         End If
    
43.         ii = ii - 1
    
44.     Next
    
45. End Sub
    
46. Sub Bingo(No As Integer)
    
47.     Dim f As Range, d As Integer, C As Range, i As Integer, ii As Integer
    
48.     Set f = Rng.Find(No, LookIn:=xlValues, LOOKAT:=xlWhole)     '尋找數字
    
49.     If f Is Nothing Then Exit Sub
    
50.     If Not f Is Nothing Then
    
51.         f.Font.ColorIndex = 3              '找到數字給字體顏色
    
52.         f.Font.FontStyle = "粗體"           '找到數字給字型樣式
    
53.     End If
    
54.     For i = 1 To Rng.Columns.Count
    
55.         d = 0
    
56.         For Each C In Rng.Columns(i).Cells
    
57.             If C.Font.ColorIndex = 3 Then d = d + 1
    
58.         Next
    
59.         If d = 5 Then Rng.Columns(i).Select: GoTo ok
    
60.      Next
    
61.     For i = 1 To Rng.Rows.Count                               '檢查橫列
    
62.         d = 0
    
63.         For Each C In Rng.Rows(i).Cells
    
64.             If C.Font.ColorIndex = 3 Then d = d + 1
    
65.         Next
    
66.         If d = 5 Then Rng.Rows(i).Select: GoTo ok
    
67.     Next
    
68.     d = 0
    
69.     For Each C In Rng1                                          '檢查對角線
    
70.             If C.Font.ColorIndex = 3 Then d = d + 1
    
71.     Next
    
72.     If d = 5 Then Rng1.Select: GoTo ok
    
73.     d = 0
    
74.     For Each C In Rng2                                          '檢查對角線
    
75.             If C.Font.ColorIndex = 3 Then d = d + 1
    
76.     Next
    
77.     If d = 5 Then Rng2.Select: GoTo ok
    
78. Exit Sub
    
79. ok:
    
80. MsgBox "Bingo"
    
81. End Sub

複製代碼

Hsieh

回復 1# 小俠客

1. Public k%
   
2. Sub Draw()
   
3. If Application.CountA([A:A]) >= k ^ 2 Then Exit Sub
   
4. n = Int((k ^ 2) * Rnd + 1)
   
5. Do Until IsError(Application.Match(n, [A:A], 0))
   
6. n = Int((k ^ 2) * Rnd + 1)
   
7. Loop
   
8. r = Application.CountA([A:A]) + 1
   
9. [A5].Offset(r) = n
   
10. Set a = Range("I1").CurrentRegion.Find(n, lookat:=xlWhole)
    
11. a.Interior.ColorIndex = 3
    
12. Set b = a.EntireColumn
    
13. Set c = a.EntireRow
    
14. ar = Array(b, c)
    
15. For i = 0 To 1
    
16. yn = True
    
17. For Each x In Intersect(ar(i), Range("I1").CurrentRegion)
    
18.    If x.Interior.ColorIndex <> 3 Then yn = False: Exit For
    
19. Next
    
20. If yn = True Then MsgBox "Bango!!!": Exit Sub
    
21. Next
    
22. Set b = [I1]
    
23. Set c = [I1].Offset(, k - 1)
    
24. ar = Array(b, c)
    
25. For i = 0 To 1
    
26. yn = True: x = IIf(i = 0, 1, -1)
    
27.   For j = 0 To k - 1
    
28.   If ar(i).Offset(j, j * x).Interior.ColorIndex <> 3 Then yn = False: Exit For
    
29.   Next
    
30.    If yn = True Then MsgBox "Bango!!!": Exit Sub
    
31. Next
    
32. End Sub
    
33. 
    
34. 
    
35. Sub Restart()
    
36. Sheets(1).Cells.Clear
    
37. Sheets(2).Cells.Clear
    
38. Sheets(3).Cells.Clear
    
39. End Sub
    
40. 
    
41. Sub Paper()
    
42. 
    
43. k = InputBox("輸入陣列維數", , 5)
    
44. ReDim ar(k, k)
    
45. ReDim ay(k, k)
    
46. For i = 0 To k - 1
    
47.    For j = 0 To k - 1
    
48.    ar(i, j) = Rnd
    
49.    Next
    
50. Next
    
51. [I1].Resize(k, k) = ar
    
52. For i = 0 To k - 1
    
53.    For j = 0 To k - 1
    
54.    ay(i, j) = Application.Rank(ar(i, j), [I1].Resize(k, k))
    
55.    Next
    
56. Next
    
57. [I1].Resize(k, k) = ay
    
58. 
    
59. End Sub

複製代碼