- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
回復 8# yeh6712 - Option Explicit
- Sub Ex1()
- Dim i As Integer, J As Integer, A As Integer, AJ(), AA()
- UsedRange.Offset(1, 2) = ""
- ReDim AJ(1 To [B1].End(xlDown).Row - 1)
- ReDim AA(1 To [A1].End(xlDown).Row - 1)
- '**** 人人有獎(一項)
- Do Until i + 1 = [A1].End(xlDown).Row '人員
- J = Int((([B1].End(xlDown).Row - 1) * Rnd) + 1) '亂數介於 1 - 獎項數量 之間
- If AJ(J) = "" Then
- A = Int((([A1].End(xlDown).Row - 1) * Rnd) + 1) '亂數介於 1 - 人員數量 之間
- If AA(A) = "" Then
- AJ(J) = J
- AA(A) = J
- Range("C" & J + 1) = Range("A" & A + 1) '獎品得獎人員
- i = i + 1
- End If
- End If
- Loop
- '**** 抽出剩餘的獎項
- For J = 1 To UBound(AJ)
- If AJ(J) = "" Then '未抽出的獎項
- Do
- A = Int((([A1].End(xlDown).Row - 1) * Rnd) + 1) '亂數介於 1 - 人員數量 之間
- If InStr(AA(A), ",") = 0 Then 'InStr(AA(A), ",") = 0;排除得2個以上獎項
- AA(A) = AA(A) & "," & J
- Range("C" & J + 1) = Range("A" & A + 1)
- Exit Do
- End If
- Loop
- End If
- Next
- [D2].Resize(UBound(AA)) = Application.WorksheetFunction.Transpose(AA) '人員的得獎獎品
- End Sub
|
|
發表於 2014-1-20 20:00
| 