麻辣家族討論版版 - Powered by Discuz! Board

標題: 如何透過VBA隨機"萬中取一"(但不能重複),抽完一萬次 [打印本頁]

作者: PKKO 時間: 2014-8-16 22:52 標題: 如何透過VBA隨機"萬中取一"(但不能重複),抽完一萬次

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

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

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

作者: GBKEE 時間: 2014-8-17 06:13

回復 1# PKKO

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

作者: PKKO 時間: 2014-8-18 09:30

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

作者: PKKO 時間: 2014-8-18 14:17

回復 3# PKKO

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

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

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

複製代碼

作者: GBKEE 時間: 2014-8-18 16:39

本帖最後由 GBKEE 於 2014-8-19 20:16 編輯

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

Option Explicit
Sub Ex1()
Application.ScreenUpdating = True
Dim i As Long, Msg As Integer
Randomize ' 對亂數產生器做初始化的動作。
For i = 1 To 10000
Do
Cells(i, "a") = Int(10000 * Rnd + 1) '亂數號碼
Msg = Application.CountIf([a1:a10000], Cells(i, "a"))
DoEvents
Loop Until Msg = 1
Next
End Sub
'******************************
Sub Ex()
Dim d As Object, y As Integer, A
Set d = CreateObject("scripting.dictionary")
Randomize ' 對亂數產生器做初始化的動作。
Do
y = Int(10000 * Rnd + 1)
d(y) = y
Loop Until d.Count = 10000
Range("A1").Resize(10000) = Application.Transpose(d.ITEMS)
End Sub

複製代碼

作者: stillfish00 時間: 2014-8-19 17:12

本帖最後由 stillfish00 於 2014-8-19 17:15 編輯

供參考:

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

複製代碼

作者: GBKEE 時間: 2014-8-19 20:34

回復 6# stillfish00

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

複製代碼

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

作者: stillfish00 時間: 2014-8-20 08:36

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

感謝指正!!

作者: stillfish00 時間: 2014-8-20 09:12

本帖最後由 stillfish00 於 2014-8-20 09:30 編輯

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

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

複製代碼

作者: PKKO 時間: 2014-8-21 14:48

回復 9# stillfish00

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

可以再請教您一下:

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

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

作者: stillfish00 時間: 2014-8-21 19:44

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

Sub test()
Dim ar1, ar2, ar3, ar
Dim i As Integer, j As Integer, k As Integer, n As Long
Dim t, s As String
t = Timer
ar1 = [A1:A100].Value
ar2 = [B1:B100].Value
ar3 = [C1:C100].Value
ReDim ar(1 To UBound(ar1) * UBound(ar2) * UBound(ar3), 1 To 1)
n = 0
For i = 1 To 100
For j = 1 To 100
s = ar1(i, 1) & ar2(j, 1)
For k = 1 To 100
n = n + 1
ar(n, 1) = s & ar3(k, 1)
Next
Next
Next
Debug.Print Timer - t '小於1秒
Application.ScreenUpdating = False
[E1].Resize(UBound(ar)).Value = ar '把結果從array放到工作表上花費最多時間
Application.ScreenUpdating = True
Debug.Print Timer - t '約 1X 秒
End Sub

複製代碼

作者: Hsieh 時間: 2014-8-22 15:15

回復 1# PKKO
10000不重複取值

Sub ex()
Set d = CreateObject("Scripting.dictionary")
Ar = [A1:A10000].Value
Do Until d.Count = 10000
Randomize
k = Int(10000 * Rnd + 1)
d(k) = Ar(k, 1)
Loop
[B1].Resize(10000, 1) = Application.Transpose(d.items)
Set d = Nothing
End Sub

複製代碼

至於1000000次
3欄各100格資料

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

複製代碼

作者: PKKO 時間: 2014-8-23 02:10

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

作者: toromru 時間: 2015-7-24 10:59

詢問 #11 與 #12

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

複製代碼

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

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

作者: toromru 時間: 2015-7-24 13:05

回復 11# stillfish00
回復 12# Hsieh

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

複製代碼

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

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

作者: PKKO 時間: 2015-7-24 13:59

回復 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 時間: 2015-7-27 13:27

回復 16# PKKO

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

作者: toromru 時間: 2015-7-27 14:12

回復 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

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