如何透過VBA隨機"萬中取一"(但不能重複),抽完一萬次

PKKO

如題,小弟用EXCEL的函數寫得出來
但後來發現EXCEL函數太多了(畢竟一萬個儲存格)
速度會變成慢到不行

所以假設D1:D10000都是不同的值
要如何每次都是隨機在這一萬格裡取一個值
連續執行一萬次
但都不能重複
直到最後一個值被取完結束呢?

PS:取完的同時清除記憶體,因為下次還要繼續執行同樣的程式,避免記憶體不足
不好意思,麻煩各位先進了...

GBKEE

回復 1# PKKO

如何隨機選號? 有討論的主題

PKKO

感謝大大,小弟將程式改編,已經可以正常使用,非常感激^_^

PKKO

回復 3# PKKO


    因為我在公司不能上傳附件,小弟附上程式碼以及公式
    因為vba還不熟悉的關係,配合函數使用= =請別見怪

1.先在b11的位置輸入=IFERROR(VLOOKUP(B10,F:F,1,FALSE),"NO")
2.將data放置在d欄
3.執行巨集

1. Sub test()
   
2.    
   
3. Application.ScreenUpdating = False
   
4.     Dim x As Long
   
5.     Dim y As Long
   
6.     Columns("F:F").ClearContents
   
7.     x = WorksheetFunction.CountA(Range("d:d"))
   
8.     i = 1
   
9. Do While i <= x
   
10.         Randomize  ' 對亂數產生器做初始化的動作。
    
11.         y = Int((x - 1 + 1) * Rnd + 1) '亂數號碼
    
12.         Cells(10, 2).Value = Cells(y, 4).Value
    
13.     If Cells(11, 2).Value = "NO" Then           '如果重複則重新跑回圈(i部會+1)
    
14.         Cells(i, 6).Value = Cells(10, 2).Value  '如果沒有重複則將DATA放在F欄
    
15.         i = i + 1
    
16.     End If
    
17. Loop   
    
18. End Sub

複製代碼

GBKEE

回復 4# PKKO
還有可參考一下

1. Option Explicit
   
2. Sub Ex1()
   
3.     Application.ScreenUpdating = True
   
4.     Dim i As Long, Msg As Integer
   
5.     Randomize  ' 對亂數產生器做初始化的動作。
   
6.     For i = 1 To 10000
   
7.         Do
   
8.             Cells(i, "a") = Int(10000 * Rnd + 1) '亂數號碼
   
9.            Msg = Application.CountIf([a1:a10000], Cells(i, "a"))
   
10.            DoEvents
    
11.         Loop Until Msg = 1
    
12.     Next
    
13. End Sub
    
14. '******************************
    
15. Sub Ex()
    
16.     Dim d As Object, y As Integer, A
    
17.     Set d = CreateObject("scripting.dictionary")
    
18.     Randomize  ' 對亂數產生器做初始化的動作。
    
19.     Do
    
20.         y = Int(10000 * Rnd + 1)
    
21.         d(y) = y
    
22.     Loop Until d.Count = 10000
    
23.     Range("A1").Resize(10000) = Application.Transpose(d.ITEMS)
    
24. End Sub

複製代碼

stillfish00

供參考:

1. Sub test()  '隨機取出指定個數的不重複
   
2.   Dim ar, num As Long, r, tmp
   
3.   
   
4.   ar = [D1:D10000].Value  '原始資料(必須是不重複值)
   
5.   num = 10000 '設定取幾個值
   
6.   
   
7.   Randomize '初始化隨機函數Rnd()的種子  
   
8.   For i = 1 To num
   
9.     '從i到最後一筆取出一個
   
10.     r = Int(Rnd * UBound(ar) - i) + i
    
11.     '取到的換到前面
    
12.     tmp = ar(r, 1)
    
13.     ar(r, 1) = ar(i, 1)
    
14.     ar(i, 1) = tmp
    
15.   Next
    
16.   
    
17.   '依序結果到F欄
    
18.   [F1].Resize(num) = ar
    
19. End Sub

複製代碼

GBKEE

回復 6# stillfish00

1. r = Int(Rnd * UBound(ar) - i) + i

複製代碼

r有機率為0, tmp = ar(r, 1)會出錯

stillfish00

回復 7# GBKEE
抱歉，少了括號
r = Int(Rnd * (UBound(ar) - i)) + i

感謝指正!!

stillfish00

回復 7# GBKEE
思慮不周:L  ，應該是
r = Int(Rnd * (UBound(ar) - i+1)) + i

1. Sub test()  '隨機取出指定個數的不重複
   
2.   Dim ar, num As Long, r, tmp
   
3.   
   
4.   ar = [D1:D10000].Value  '原始資料(必須是不重複值)
   
5.   num = 10000 '設定取幾個值
   
6.   
   
7.   Randomize '初始化隨機函數Rnd()的種子  
   
8.   For i = 1 To num
   
9.     '從i到最後一筆取出一個
   
10.     r = Int(Rnd * (UBound(ar) - i + 1 )) + i
    
11.     '取到的換到前面
    
12.     tmp = ar(r, 1)
    
13.     ar(r, 1) = ar(i, 1)
    
14.     ar(i, 1) = tmp
    
15.   Next
    
16.   
    
17.   '依序結果到F欄
    
18.   [F1].Resize(num) = ar
    
19. End Sub

複製代碼

PKKO

回復 9# stillfish00


    大大太厲害了,我看了滿久的還是看不是很懂,為何他不會重複,以及RESIZE的方法是如何應用的

可以再請教您一下:

若是A~C欄都各有一百格資料

我想要進行排列組合,也就是A1 & B1 & C1 然後A2 & B1 & C1 以此類推,每個組合都要有也就是100*100*100=100萬的組合
如何跑最快,我寫的程式跑得有點久...