抽獎的巨集

yeh6712

如圖，A欄有10個人(A～J)，B欄有4個物品(1～4)，
10個人要抽這4個物品，請問如何用巨集，在C欄中顯示抽中的人的物品號碼？謝謝…！
  

下載 (20.56 KB)

2014-1-10 17:00

stillfish00

回復 1# yeh6712
用VBA時，因為Rank第二參數好像不支援array形式，所以像下面這樣囉嗦了一點
物品欄也可以不用數字

1. Sub TEST()
   
2.   Dim rngTest As Range, rngB As Range, ar, i
   
3.   
   
4.   With ActiveSheet
   
5.     Set rngTest = .Range(.[A2], .Cells(.Rows.Count, "A").End(xlUp)).Offset(, 2)
   
6.     Set rngB = .Range(.[B2], .Cells(.Rows.Count, "B").End(xlUp))
   
7.    
   
8.     Randomize Now
   
9.     For i = 1 To rngTest.Count
   
10.       rngTest(i).Value = Rnd
    
11.     Next
    
12.    
    
13.     ReDim ar(1 To rngTest.Count)
    
14.     For i = LBound(ar) To UBound(ar)
    
15.       ar(i) = Application.WorksheetFunction.Rank(rngTest(i).Value, rngTest)
    
16.       ar(i) = IIf(ar(i) > rngB.Count, "", rngB(ar(i)))
    
17.     Next
    
18.    
    
19.     rngTest.Value = Application.Transpose(ar)
    
20.   End With
    
21. End Sub

複製代碼

yeh6712

回復 2# stillfish00

感謝…！太厲害了…
看懂了，是把所得的亂數值排序後，再填上排序值，排序值超過B欄個數，就填空格，對嗎？

另一問：如果想把抽中人員直接寫在各個號碼右邊的欄位，那如何修改呢？謝謝…（如附圖）

下載 (6.62 KB)

2014-1-18 21:55

stillfish00

回復 3# yeh6712
新增一行就好
    For i = LBound(ar) To UBound(ar)
        ar(i) = Application.WorksheetFunction.Rank(rngTest(i).Value, rngTest)
        rngB(ar(i)).Offset(, 2).Value = IIf(ar(i) > rngB.Count, "", rngTest(i).Offset(, -2).Value)
        ar(i) = IIf(ar(i) > rngB.Count, "", rngB(ar(i)))
    Next

yeh6712

回復 4# stillfish00

太棒了…真感謝，小的再好好研究一下…

Hsieh

回復 3# yeh6712

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. s = Application.CountA([A:A]) - 1
   
4. UsedRange.Offset(1, 2) = ""
   
5. For i = 1 To Application.CountA([B:B]) - 1 '獎項
   
6.     Do
   
7.        j = Int((s * Rnd) + 1)
   
8.     Loop Until d.exists(j) = False
   
9.     d(j) = i
   
10.     Range([A2], [A2].End(xlDown)).Cells(j).Offset(, 2) = i 'C欄得獎
    
11.     Range([B2], [B2].End(xlDown)).Cells(i).Offset(, 2) = Range([A2], [A2].End(xlDown)).Cells(j)  'D欄得獎
    
12. Next
    
13. End Sub

複製代碼

下載 (72.87 KB)

2014-1-20 16:57

GBKEE

回復 5# yeh6712
還有寫法,可研究.

1. Option Explicit
   
2. Sub Ex1()
   
3.     Dim i, J
   
4.     UsedRange.Offset(1, 2) = ""
   
5.     Do Until i + 1 = [B1].End(xlDown).Row                  '獎項
   
6.         J = Int((([A1].End(xlDown).Row - 1) * Rnd) + 1)    '亂數介於 1 - 人員數量 之間
   
7.         If Range("C" & J + 1) = "" Then
   
8.             Range("C" & J + 1) = i + 1
   
9.             Range("D" & i + 2) = Range("A" & J + 1)
   
10.             i = i + 1
    
11.         End If
    
12.     Loop
    
13. End Sub

複製代碼

yeh6712

我有另一個想法：若人員有10人，獎項有15個；那就人人有獎，但只抽出10個，

所以抽中的不見得就是1～10號的獎項，如何改寫呢？

如果用上面大大的寫法，一定會只抽中1～10號，又或是迴圈跑不完…

感謝啦…！

GBKEE

回復 8# yeh6712

1. Option Explicit
   
2. Sub Ex1()
   
3.     Dim i As Integer, J As Integer, A As Integer, AJ(), AA()
   
4.     UsedRange.Offset(1, 2) = ""
   
5.     ReDim AJ(1 To [B1].End(xlDown).Row - 1)
   
6.     ReDim AA(1 To [A1].End(xlDown).Row - 1)
   
7.     '**** 人人有獎(一項)
   
8.     Do Until i + 1 = [A1].End(xlDown).Row                  '人員
   
9.         J = Int((([B1].End(xlDown).Row - 1) * Rnd) + 1)    '亂數介於 1 - 獎項數量 之間
   
10.         If AJ(J) = "" Then
    
11.             A = Int((([A1].End(xlDown).Row - 1) * Rnd) + 1)    '亂數介於 1 - 人員數量 之間
    
12.             If AA(A) = "" Then
    
13.                 AJ(J) = J
    
14.                 AA(A) = J
    
15.                 Range("C" & J + 1) = Range("A" & A + 1)        '獎品得獎人員
    
16.                 i = i + 1
    
17.             End If
    
18.         End If
    
19.     Loop
    
20.     '**** 抽出剩餘的獎項
    
21.     For J = 1 To UBound(AJ)
    
22.         If AJ(J) = "" Then     '未抽出的獎項
    
23.             Do
    
24.                 A = Int((([A1].End(xlDown).Row - 1) * Rnd) + 1)    '亂數介於 1 - 人員數量 之間
    
25.                 If InStr(AA(A), ",") = 0 Then         'InStr(AA(A), ",") = 0;排除得2個以上獎項
    
26.                     AA(A) = AA(A) & "," & J
    
27.                     Range("C" & J + 1) = Range("A" & A + 1)
    
28.                     Exit Do
    
29.                 End If
    
30.             Loop
    
31.         End If
    
32.     Next
    
33.     [D2].Resize(UBound(AA)) = Application.WorksheetFunction.Transpose(AA)  '人員的得獎獎品
    
34. End Sub

複製代碼

yeh6712

回復 9# GBKEE

大大我執行後，只會有A抽到且是1號，其餘都是空白耶…