設計一個對獎程式

flutist

請問如何設計一個對獎程式?我有附件

test.rar (2.45 KB)

下載次數: 27

2012-12-11 15:32

stillfish00

回復 1# flutist
蠻偷懶的寫法...

1. Sub LottoRun()
   
2.     With Sheets("Sheet1").[D2]
   
3.     Select Case [=IFERROR(SUM(COUNTIF(Sheet1!B2:B6,OFFSET(Sheet2!B1:G1,MATCH(Sheet1!A2,Sheet2!A:A,0)-1,)))*10+(B7=OFFSET(Sheet2!H1,MATCH(Sheet1!A2,Sheet2!A:A,0)-1,)),-1)]
   
4.         Case 61
   
5.             .Value = "恭喜你對中頭獎"
   
6.         Case 51
   
7.             .Value = "恭喜你對中貳獎"
   
8.         Case 50
   
9.             .Value = "恭喜你對中參獎"
   
10.         Case 41
    
11.             .Value = "恭喜你對中肆獎"
    
12.         Case 40
    
13.             .Value = "恭喜你對中伍獎"
    
14.         Case 31
    
15.             .Value = "恭喜你對中陸獎，獎金$1,000"
    
16.         Case 30
    
17.             .Value = "恭喜你對中普獎，獎金$400"
    
18.         Case -1
    
19.             .Value = "期別找不到"
    
20.         Case Else
    
21.             .Value = "殘念"
    
22.     End Select
    
23.     .EntireColumn.AutoFit
    
24.     End With
    
25. End Sub

複製代碼

stillfish00

更正 頭獎為Case 60

stillfish00

應該是Case 60, 61  

Hsieh

回復 1# flutist
基本上使用公式即可達成，寫成VBA最好配合事件程序

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Intersect(Target, [B3:B7]) Is Nothing Then Exit Sub
   
3. If Application.CountIf(Sheet2.[A:A], Sheet1.[A2]) = 0 Then Sheet1.[D2] = "期別錯誤": Exit Sub '期別錯誤
   
4. '基本號碼
   
5. x = _
   
6. Evaluate("=SUMPRODUCT(ISNUMBER(1/COUNTIF(OFFSET(Sheet2!$A$1,MATCH(Sheet1!$A$2,Sheet2!$A:$A,0)-1,1,,6),Sheet1!$B$2:$B$7))*1)")
   
7. '特別號
   
8. y = _
   
9. Evaluate("=ISNUMBER(MATCH(OFFSET(Sheet2!$A$1,MATCH(Sheet1!$A$2,Sheet2!$A:$A,0)-1,7),Sheet1!$B$2:$B$7,0))*0.5")
   
10. Sheet1.[D2] = Application.Lookup(x + y, Array(0, 3, 3, 5, 4, 4.5, 5, 5.5, 6), Array("未中獎", "普獎", "陸獎", "伍獎", "肆獎", "三獎", "貳獎", "頭獎"))
    
11. End Sub

複製代碼

flutist

公式我會設計
但VBA就不行了
謝謝前輩指導

GBKEE

回復 6# flutist

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim 期別 As Range, Msg As String, xi As Integer, xS As Integer
   
4.     With Sheets("Sheet1")
   
5.         .[B2:B7].Name = "投注區"
   
6.         Set 期別 = Sheets("sheet2").Range("a:a").Find(.[a2], lookat:=xlWhole)       '尋找期別
   
7.         Msg = IIf(期別 Is Nothing, "期    別:" & .[a2] & " 找不到!!! " & vbLf, "") & _
   
8.               IIf([COUNT(投注區)] <> 6, "投注區: 號碼不齊全", "")                   '[COUNT(投注區)] <> 6 投注號碼需有6個
   
9.         If Msg <> "" Then MsgBox Msg: Exit Sub
   
10.         [投注區].Interior.ColorIndex = .[a2].Interior.ColorIndex                    '制定投注區底色
    
11.         For xi = 1 To 7
    
12.             If IsNumeric(Application.Match(期別.Offset(, xi), [投注區], 0)) Then    '開出獎號一一比對   投注號碼
    
13.                 If xi < 6 Then
    
14.                  xS = xS + 1
    
15.                  [投注區].Cells(Application.Match(期別.Offset(, xi), [投注區], 0)).Interior.ColorIndex = 17  '開出號號:制定底色
    
16.                 Else
    
17.                   Msg = "OK"        '特別號
    
18.                   [投注區].Cells(Application.Match(期別.Offset(, xi), [投注區], 0)).Interior.ColorIndex = 7   '特別號:制定底色
    
19.                 End If
    
20.             End If
    
21.         Next
    
22.         With .[D2]
    
23.             Select Case xS
    
24.                 Case 6
    
25.                     .Value = "「恭喜你對中頭獎」"
    
26.                 Case 5
    
27.                     .Value = IIf(Msg <> "", "「恭喜你對中貳獎」", "「恭喜你對中參獎」")
    
28.                 Case 4
    
29.                     .Value = IIf(Msg <> "", "「恭喜你對中肆獎」", "「恭喜你對中伍獎」")
    
30.                 Case 3
    
31.                     .Value = IIf(Msg <> "", "「恭喜你對中陸獎」", "「獎金$1,000」")
    
32.                 Case 2
    
33.                     .Value = IIf(Msg <> "", "「恭喜你對中普獎」", "「獎金$400」")
    
34.                 Case Else
    
35.                 .Value = "下期再來"
    
36.             End Select
    
37.         End With
    
38.     End With

複製代碼

freeffly

以前100組100萬時有看過人家用函數搭配簡單的vba
不過主要是以函數為主
第一次看到用vba對獎的