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

PKKO

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

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

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

toromru

回復 16# PKKO


    您好
      增加了兩個需求，想詢問。
     
       假設
            1. 如果要將隨機取的值 在 原始資料的X欄位標記已取
            2 在隨機取的前置條件為X欄位未標記的才進行篩選.


       例如:    A為原始資料  B為隨機取的值   X為標記
                  
                 第一次隨選       第二次隨選     第三次隨選         
                    A   X   B             A   X   B            A    X    B
                    1         2             1         1            1    O    3
                    2                        2    O                2     O
                    3                        3                       3

toromru

回復 16# PKKO


    謝謝  已成功如我需求的抽出 : )

PKKO

回復 15# toromru


ar = [D1:D10000].Value
如果純粹是這行,有很多方式
'自動選擇到最下面一列
AR=RANGE("d1:d" & [D65536].END(XLUP).ROW).VALUE
'輸入方式
X1=INPUTBOX("請輸入d欄數字")
AR=RANGE("d1:d" & X1 ).VALUE
'某個位置或是某個變數假設是[A2]
AR=RANGE("d1:d" & [A2] ).VALUE

'這幾個方法都因該要設定偵錯的方式,避免沒有數字、d欄沒有值、[A2]為空等問題~

toromru

回復 11# stillfish00
回復 12# Hsieh

1.    ar = [D1:D10000].Value  '原始資料(必須是不重複值)

複製代碼

這行 能否自動抓取 D欄位的數量 不要預設10000

例如
我的資料有2000筆 但不一定每次都是2000筆
不想預設每一次都要重新輸入筆數。

toromru

詢問 #11 與 #12

1. ar = [D1:D10000].Value  '原始資料(必須是不重複值)

複製代碼

這行 能否自動抓取 D欄位的數量 不要預設10000

例如
我的資料有2000筆 但不一定每次都是2000筆
不想預設每一次都要重新輸入筆數。

PKKO

感謝各位大大,時間上真的快多了
看來我得先多學習一下陣列的使用方式
感激不盡!!!

Hsieh

回復 1# PKKO
10000不重複取值

1. Sub ex()
   
2. Set d = CreateObject("Scripting.dictionary")
   
3. Ar = [A1:A10000].Value
   
4. Do Until d.Count = 10000
   
5. Randomize
   
6. k = Int(10000 * Rnd + 1)
   
7. d(k) = Ar(k, 1)
   
8. Loop
   
9. [B1].Resize(10000, 1) = Application.Transpose(d.items)
   
10. Set d = Nothing
    
11. End Sub

複製代碼

至於1000000次
3欄各100格資料

1. Sub nn()
   
2. Dim ar(1000000, 3)
   
3. t = Timer
   
4. For Each a In [A1:A100]
   
5.    For Each b In [B1:B100]
   
6.       For Each c In [C1:C100]
   
7.          ar(s, 0) = a: ar(s, 1) = b: ar(s, 2) = c
   
8.          s=s+1
   
9.       Next
   
10.     Next
    
11.     Next
    
12.     [D1].Resize(1000000, 3) = ar
    
13.     MsgBox Timer - t  '共花費的時間秒數
    
14. End Sub

複製代碼

stillfish00

回復 10# PKKO
僅供參考，不同電腦執行時間也不同

1. Sub test()
   
2.   Dim ar1, ar2, ar3, ar
   
3.   Dim i As Integer, j As Integer, k As Integer, n As Long
   
4.   Dim t, s As String
   
5.   
   
6.   t = Timer
   
7.   ar1 = [A1:A100].Value
   
8.   ar2 = [B1:B100].Value
   
9.   ar3 = [C1:C100].Value
   
10.   ReDim ar(1 To UBound(ar1) * UBound(ar2) * UBound(ar3), 1 To 1)
    
11.   n = 0
    
12.   For i = 1 To 100
    
13.     For j = 1 To 100
    
14.       s = ar1(i, 1) & ar2(j, 1)
    
15.       For k = 1 To 100
    
16.         n = n + 1
    
17.         ar(n, 1) = s & ar3(k, 1)
    
18.       Next
    
19.     Next
    
20.   Next
    
21.   
    
22.   Debug.Print Timer - t     '小於1秒
    
23.   
    
24.   Application.ScreenUpdating = False
    
25.   [E1].Resize(UBound(ar)).Value = ar    '把結果從array放到工作表上花費最多時間
    
26.   Application.ScreenUpdating = True
    
27.   
    
28.   Debug.Print Timer - t     '約 1X 秒
    
29. End Sub

複製代碼

PKKO

回復 9# stillfish00


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

可以再請教您一下:

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

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