返回列表 上一主題 發帖

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

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
1# 跳轉到 »
發表於 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

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
2#
發表於 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 
3#
發表於 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

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
4#
發表於 2014-8-21 19:44 | 顯示全部帖子
回復 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
複製代碼

TOP

        靜思自在 : 每天無所事事，是人生的消費者，積極、有用才是人生的創造者。
返回列表 上一主題