Board logo

標題: 抽獎的巨集 [打印本頁]
作者: yeh6712    時間: 2014-1-10 17:00     標題: 抽獎的巨集

本帖最後由 yeh6712 於 2014-1-10 17:02 編輯

如圖，A欄有10個人(A∼J)，B欄有4個物品(1∼4)，
10個人要抽這4個物品，請問如何用巨集，在C欄中顯示抽中的人的物品號碼？謝謝…！
  [attach]17238[/attach]
作者: stillfish00    時間: 2014-1-13 20:24

本帖最後由 stillfish00 於 2014-1-13 20:36 編輯

回復 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    時間: 2014-1-18 21:55

回復 2# stillfish00

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

另一問：如果想把抽中人員直接寫在各個號碼右邊的欄位，那如何修改呢？謝謝…（如附圖）
[attach]17301[/attach]
作者: stillfish00    時間: 2014-1-18 22:27

回復 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    時間: 2014-1-18 23:30

回復 4# stillfish00

太棒了…真感謝，小的再好好研究一下…
作者: Hsieh    時間: 2014-1-20 16:57

回復 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
複製代碼
[attach]17325[/attach]
作者: GBKEE    時間: 2014-1-20 20:00

回復 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    時間: 2014-1-26 15:36

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

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

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

感謝啦…！
作者: GBKEE    時間: 2014-1-28 09:48

回復 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    時間: 2014-1-28 23:42

回復 9# GBKEE

大大我執行後，只會有A抽到且是1號，其餘都是空白耶…
作者: yeh6712    時間: 2014-2-6 09:07

回復  GBKEE

大大我執行後，只會有A抽到且是1號，其餘都是空白耶…
yeh6712 發表於 2014-1-28 23:42


哈哈…抱歉，是我操作錯誤，程式無誤…



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)