12
返回列表 上一主題 發帖

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

PKKO
　暱稱: PKKO

高中生Rank: 3Rank: 3

帖子
549 
主題
152 
精華
0 
積分
691 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE 2010 
閱讀權限
50 
性別
男 
註冊時間
2013-8-10 
最後登錄
2022-9-7 

論壇榮譽勳章論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2014-8-16 22:52 | 只看該作者

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

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

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

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

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2014-8-17 06:13 | 只看該作者
回復 1# PKKO

如何隨機選號? 有討論的主題
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

PKKO
　暱稱: PKKO

高中生Rank: 3Rank: 3

帖子
549 
主題
152 
精華
0 
積分
691 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE 2010 
閱讀權限
50 
性別
男 
註冊時間
2013-8-10 
最後登錄
2022-9-7 

論壇榮譽勳章論壇贊助勳章
3#
發表於 2014-8-18 09:30 | 只看該作者
感謝大大,小弟將程式改編,已經可以正常使用,非常感激^_^
PKKO

TOP

PKKO
　暱稱: PKKO

高中生Rank: 3Rank: 3

帖子
549 
主題
152 
精華
0 
積分
691 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE 2010 
閱讀權限
50 
性別
男 
註冊時間
2013-8-10 
最後登錄
2022-9-7 

論壇榮譽勳章論壇贊助勳章
4#
發表於 2014-8-18 14:17 | 只看該作者
回復 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
複製代碼
PKKO

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 2014-8-18 16:39 | 只看該作者
本帖最後由 GBKEE 於 2014-8-19 20:16 編輯

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
6#
發表於 2014-8-19 17:12 | 只看該作者
本帖最後由 stillfish00 於 2014-8-19 17:15 編輯

供參考:
  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
複製代碼

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
7#
發表於 2014-8-19 20:34 | 只看該作者
回復 6# stillfish00
  1. r = Int(Rnd * UBound(ar) - i) + i
複製代碼
r有機率為0, tmp = ar(r, 1)會出錯
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
8#
發表於 2014-8-20 08:36 | 只看該作者
回復 7# GBKEE
抱歉，少了括號
r = Int(Rnd * (UBound(ar) - i)) + i

感謝指正!!

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
9#
發表於 2014-8-20 09:12 | 只看該作者
本帖最後由 stillfish00 於 2014-8-20 09:30 編輯

回復 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
複製代碼

TOP

PKKO
　暱稱: PKKO

高中生Rank: 3Rank: 3

帖子
549 
主題
152 
精華
0 
積分
691 
點名
0  
作業系統
WIN7 
軟體版本
OFFICE 2010 
閱讀權限
50 
性別
男 
註冊時間
2013-8-10 
最後登錄
2022-9-7 

論壇榮譽勳章論壇贊助勳章
10#
發表於 2014-8-21 14:48 | 只看該作者
回復 9# stillfish00


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

可以再請教您一下:

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

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

TOP

        靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。
12
返回列表 上一主題