[已解决]这样的VBA程序怎么写？

hamsik11

我有10个数，
a1 2
a2 4
a3 1
a4 6
a5 10
a6 11
a7  8
a8 9
a9  11
a10 10

左边是变量名，右边他的数值，我想实现这样的抽样。从这10个数中抽出3个，每个被抽中的几率是他本身的数值和这十个数值的和的比例。
譬如a1被抽中的可能性为a1/sum(a1-a10).
哪位老师可以指点一下 谢谢啦

最佳答案

月排行榜 / 总排行榜

liuguansky

2012-2-6 14:26

hamsik11 发表于 2012-2-6 13:30
你好 老师 兄弟实在太挫了 倒腾了一个上午都没搞定，干脆上文件了，老师能不能帮我弄一下。其中a列是id， ...

1. Sub justtest()
   
2.     Dim Ar, d As New Dictionary, i&, ArT() As String, s$
   
3.     Const n% = 100
   
4.     ReDim ArT(1 To n, 1 To 1)
   
5.     Ar = Range("A2:b" & Cells(Rows.Count, 1).End(3).Row).Value
   
6.     For i = 1 To UBound(Ar)
   
7.         s = CStr(Ar(i, 1))
   
8.         d(s) = d(s) + Ar(i, 2)
   
9.     Next i
   
10.     If n > 0 And d.Count > 0 Then
    
11.         For i = 1 To n
    
12.             If d.Count > 0 Then
    
13.                 ArT(i, 1) = Tx(d.Items, d.Keys)
    
14.                 d.Remove ArT(i, 1)
    
15.             Else
    
16.                 Exit For
    
17.             End If
    
18.         Next
    
19.     End If
    
20.     [d1].Resize(n, 1) = ArT
    
21.     Set d = Nothing
    
22. End Sub
    
23. Function Tx(Ar As Variant, Ak As Variant) As String
    
24.     Dim i As Long, s As Long, T As Double
    
25.     s = Application.Sum(Ar)
    
26.     For i = 1 To UBound(Ar)
    
27.         Ar(i) = Ar(i - 1) + Ar(i)
    
28.     Next i
    
29.     For i = 0 To UBound(Ar) - 1
    
30.         Ar(i) = Ar(i) / s
    
31.     Next i
    
32.     Ar(i) = 1
    
33.     VBA.Randomize
    
34.     T = Rnd()
    
35.     For i = 0 To UBound(Ar)
    
36.         If Ar(i) >= T Then
    
37.             Tx = Ak(i)
    
38.             Exit For
    
39.         End If
    
40.     Next i
    
41. End Function
    

复制代码

数据源支持重复
test.rar (24.68 KB, 下载次数: 12)

2012-2-6 14:26 上传

点击文件名下载附件

跳转到最佳答案楼层

sunjing-zxl

我感觉没发实现这样的随机效果。。
期待高手来解决

liuguansky

一次取三个数没有想到思路，以下代码为一个一个取数
看下附件效果吧
123.rar (10.33 KB, 下载次数: 7)

2012-2-6 11:39 上传

点击文件名下载附件

1. Sub justtest()
   
2.     Dim Ar, d As New Dictionary, i&, ArT(1 To 3, 1 To 1) As String
   
3.     Ar = Range("A1:b" & Cells(Rows.Count, 1).End(3).Row).Value
   
4.     For i = 1 To UBound(Ar)
   
5.         d(Ar(i, 1)) = d(Ar(i, 1)) + Ar(i, 2)
   
6.     Next i
   
7.     ArT(1, 1) = Tx(d.Items, d.Keys)
   
8.     d.Remove ArT(1, 1)
   
9.     ArT(2, 1) = Tx(d.Items, d.Keys)
   
10.     d.Remove ArT(2, 1)
    
11.     ArT(3, 1) = Tx(d.Items, d.Keys)
    
12.     [d1:d3] = ArT
    
13.     Set d = Nothing
    
14. End Sub
    
15. Function Tx(Ar As Variant, Ak As Variant) As String
    
16.     Dim Arr(1 To 3), i As Long, S As Long, T As Double
    
17.     S = Application.Sum(Ar)
    
18.     For i = 1 To UBound(Ar)
    
19.         Ar(i) = Ar(i - 1) + Ar(i)
    
20.     Next i
    
21.     For i = 0 To UBound(Ar) - 1
    
22.         Ar(i) = Ar(i) / S
    
23.     Next i
    
24.     Ar(i) = 1
    
25.     VBA.Randomize
    
26.     T = Rnd()
    
27.     For i = 0 To UBound(Ar)
    
28.         If Ar(i) >= T Then
    
29.             Tx = Ak(i)
    
30.             Exit For
    
31.         End If
    
32.     Next i
    
33. End Function

复制代码

hamsik11

liuguansky 发表于 2012-2-6 11:39
一次取三个数没有想到思路，以下代码为一个一个取数
看下附件效果吧

您好 太感谢了。
能不能在上面程序上做个提示啥的，因为我的数据个数可能不止10，可能会很多，抽样也不止3.
如果增加数目的话 我应该怎么改？

谢谢您了

上清宫主

这个随机，从数学上想看是不是可以这样：
生成2个a1、 4个a2、1个a3、6个a4……，再在这个集合中来随机均等提取，这个是不是就可以达到“a1被抽中的可能性为a1/sum(a1-a10)“了？

liuguansky

hamsik11 发表于 2012-2-6 11:49
您好 太感谢了。
能不能在上面程序上做个提示啥的，因为我的数据个数可能不止10，可能会很多，抽样也不止 ...

•     ArT(1, 1) = Tx(d.Items, d.Keys)
•     d.Remove ArT(1, 1)
•     ArT(2, 1) = Tx(d.Items, d.Keys)
•     d.Remove ArT(2, 1)
•     ArT(3, 1) = Tx(d.Items, d.Keys)
  

这几句改成循环就可以了。

windimi007

liuguansky 发表于 2012-2-6 12:19

    ArT(1, 1) = Tx(d.Items, d.Keys)

    d.Remove ArT(1, 1)

    ArT(2, 1) = Tx(d.Items ...

花花老师，看看山菊花版的这段代码吧！怎么感觉怪怪的呢！求解释。{:211:}

1. Sub 抽签()
   
2.     Dim Arr(), Brr(1 To 3), m%, nSum%, nRnd
   
3.     Arr = Array(2, 4, 1, 6, 10, 11, 8, 9, 11, 10)
   
4.     nSum = WorksheetFunction.Sum(Arr)
   
5.     Randomize
   
6.     Do While m < 3
   
7.         nRnd = Int(Rnd * 10)
   
8.         If Rnd <= Arr(nRnd) / nSum Then
   
9.             m = m + 1
   
10.             Brr(m) = nRnd
    
11.             Arr(nRnd) = -1
    
12.         End If
    
13.     Loop
    
14.     'Brr()为所得结果，数值代表变量序号
    
15. End Sub

复制代码

hamsik11

liuguansky 发表于 2012-2-6 12:19

    ArT(1, 1) = Tx(d.Items, d.Keys)

    d.Remove ArT(1, 1)

    ArT(2, 1) = Tx(d.Items ...

你好 老师 兄弟实在太挫了 倒腾了一个上午都没搞定，干脆上文件了，老师能不能帮我弄一下。其中a列是id，b列是数值，从a中随机选100个，选中的概率等于各自的数值和总量的比值。谢谢了

另外，其中的算法我没看清楚，老师能指点一下吗？

liuguansky

hamsik11 发表于 2012-2-6 13:30
你好 老师 兄弟实在太挫了 倒腾了一个上午都没搞定，干脆上文件了，老师能不能帮我弄一下。其中a列是id， ...

1. Sub justtest()
   
2.     Dim Ar, d As New Dictionary, i&, ArT() As String, s$
   
3.     Const n% = 100
   
4.     ReDim ArT(1 To n, 1 To 1)
   
5.     Ar = Range("A2:b" & Cells(Rows.Count, 1).End(3).Row).Value
   
6.     For i = 1 To UBound(Ar)
   
7.         s = CStr(Ar(i, 1))
   
8.         d(s) = d(s) + Ar(i, 2)
   
9.     Next i
   
10.     If n > 0 And d.Count > 0 Then
    
11.         For i = 1 To n
    
12.             If d.Count > 0 Then
    
13.                 ArT(i, 1) = Tx(d.Items, d.Keys)
    
14.                 d.Remove ArT(i, 1)
    
15.             Else
    
16.                 Exit For
    
17.             End If
    
18.         Next
    
19.     End If
    
20.     [d1].Resize(n, 1) = ArT
    
21.     Set d = Nothing
    
22. End Sub
    
23. Function Tx(Ar As Variant, Ak As Variant) As String
    
24.     Dim i As Long, s As Long, T As Double
    
25.     s = Application.Sum(Ar)
    
26.     For i = 1 To UBound(Ar)
    
27.         Ar(i) = Ar(i - 1) + Ar(i)
    
28.     Next i
    
29.     For i = 0 To UBound(Ar) - 1
    
30.         Ar(i) = Ar(i) / s
    
31.     Next i
    
32.     Ar(i) = 1
    
33.     VBA.Randomize
    
34.     T = Rnd()
    
35.     For i = 0 To UBound(Ar)
    
36.         If Ar(i) >= T Then
    
37.             Tx = Ak(i)
    
38.             Exit For
    
39.         End If
    
40.     Next i
    
41. End Function
    

复制代码

数据源支持重复
test.rar (24.68 KB, 下载次数: 12)

2012-2-6 14:26 上传

点击文件名下载附件

hamsik11

liuguansky 发表于 2012-2-6 14:26
数据源支持重复

谢谢 谢谢各位老师