返回列表 上一主題 發帖

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

小俠客

帖子
83 
主題
17 
精華
0 
積分
105 
點名
0  
作業系統
XP 
軟體版本
XP 
閱讀權限
20 
註冊時間
2010-12-28 
最後登錄
2018-8-8 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2011-12-14 15:30 | 只看該作者

請問如何用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

帖子
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# 小俠客
  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
複製代碼

TOP

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
3#
發表於 2011-12-16 21:22 | 只看該作者
回復 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


  35. Sub Restart()
  36. Sheets(1).Cells.Clear
  37. Sheets(2).Cells.Clear
  38. Sheets(3).Cells.Clear
  39. End Sub

  41. Sub Paper()

  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

  59. End Sub
複製代碼
學海無涯_不恥下問

TOP

        靜思自在 : 有多少力量就做多少事，不要心存等待，等待才會落空。
返回列表 上一主題