[已解决]新人求教，分段随机抽取后排序的实现方法！！

ckoeng

希望各位大神等帮解决，不胜感激！！
问题简述：从样本中分段随机抽取一定量的样，放置在指定位置并按序号重新排序，详见附件所示，谢谢！

已解决，见链接
http://www.excelpx.com/thread-320855-1-1.html

最佳答案

月排行榜 / 总排行榜

dsmch

2014-3-14 17:26

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, x&, y&, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. ReDim brr(1 To 50, 1 To 2)
   
6. x = UBound(arr)
   
7. For i = 1 To UBound(brr)
   
8. line1:
   
9.     y = Int(Rnd * x + 2)
   
10.     If Not d.exists(y) Then d(y) = "" Else GoTo line1
    
11. Next
    
12. For i = 1 To d.Count
    
13.     n = Application.Small(d.keys, i)
    
14.     brr(i, 1) = arr(n, 1)
    
15.     brr(i, 2) = arr(n, 2)
    
16. Next
    
17. Range("c2").Resize(UBound(brr), 2) = brr
    
18. End Sub
    

复制代码

跳转到最佳答案楼层

zhaozhongyu

你那个序号和数据怎么都是一样的？

ckoeng

zhaozhongyu 发表于 2014-3-14 16:51
你那个序号和数据怎么都是一样的？

只是举个例子，实际情况是不一样的

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&, x&, y&, n&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. ReDim brr(1 To 50, 1 To 2)
   
6. x = UBound(arr)
   
7. For i = 1 To UBound(brr)
   
8. line1:
   
9.     y = Int(Rnd * x + 2)
   
10.     If Not d.exists(y) Then d(y) = "" Else GoTo line1
    
11. Next
    
12. For i = 1 To d.Count
    
13.     n = Application.Small(d.keys, i)
    
14.     brr(i, 1) = arr(n, 1)
    
15.     brr(i, 2) = arr(n, 2)
    
16. Next
    
17. Range("c2").Resize(UBound(brr), 2) = brr
    
18. End Sub
    

复制代码

dsmch

………………

ckoeng

dsmch 发表于 2014-3-14 17:28
………………

非常感谢！！论坛里高手和好人真多，(*^__^*) 嘻嘻……

ckoeng

dsmch 发表于 2014-3-14 17:28
………………

仔细看了下，现在的功能只是从里面抽取50个数据，我要的是每1000个数据就抽取50个数据，还是不能达到目标，可惜。不知大神是否有办法？

锋速vba

学习了，强！