VBA小模板：一个普通随机抽奖，需要模拟多轮用VBA怎么做？
问题：
1 前面已经做了一个随机的模拟，但是这次单次模拟，模拟每次抽奖抽到了什么
2 如果想模拟多轮，测试下每轮出大奖的概率，然后看下平均多少次出一次大奖
这就需要在 抽奖随机 之上再套一层循环，统计每次随到大奖的次数，再统计多轮
2 下面是代码
- 最内层是，单次抽奖随机抽1次
- 第1层循环：用 do until 循环多次，直到抽到大奖为止，
- 第2层循环：模拟多轮
Private ra1
Private bb
Private ee
Sub super_rnd1()
'为了方便测试，把EXCEL数据里大奖概率调整从10为110了，总权重和还是10000，否则大奖概率太低需要跑很久
Dim sh2
Set sh2 = ThisWorkbook.Worksheets("output1")
'每次都要，先重置输出区域
'可能每次随机模拟次数不同，老的数据只被替换掉一部分造成，污染了新跑的数据，若是写在不同文件就没这问题
sh2.Columns(11).Clear
sh2.Columns(12).Clear
ee = sh2.Cells(2, 17)
ff = sh2.Cells(2, 14) '表上调整测试的轮数
'多轮测试
For i = 1 To ff
'每轮循环开始前重置变量
ra1 = 0
bb = 1
'每次都要，先重置输出区域
sh2.Columns(1).Clear
sh2.Columns(2).Clear
sh2.Columns(3).Clear
sh2.Columns(4).Clear
sh2.Columns(5).Clear
Do Until ra1 = 13 '抽到大奖为止
Call rnd1
Dim sh1 As Object
Set sh1 = ThisWorkbook.Worksheets("data")
c1 = WorksheetFunction.Match("rank", sh1.Range("3:3"), 0)
c2 = WorksheetFunction.Match("ID", sh1.Range("3:3"), 0)
c3 = WorksheetFunction.Match("name", sh1.Range("3:3"), 0)
c4 = WorksheetFunction.Match("num", sh1.Range("3:3"), 0)
c5 = WorksheetFunction.Match("权重", sh1.Range("3:3"), 0)
sh2.Cells(bb, 1) = "第" & bb & "次"
sh2.Cells(bb, 2) = ra1
sh2.Cells(bb, 3) = Application.Index(sh1.Columns(c2), Application.Match(ra1, sh1.Columns(c1), 0)) 'id
sh2.Cells(bb, 4) = Application.Index(sh1.Columns(c3), Application.Match(ra1, sh1.Columns(c1), 0)) 'name
sh2.Cells(bb, 5) = Application.Index(sh1.Columns(c4), Application.Match(ra1, sh1.Columns(c1), 0)) 'num
'统计抽到大奖是第几次
bb = bb + 1
Loop
'统计测试轮数
dd = 1 + dd
Debug.Print "本次抽中大奖是第" & bb-1 & "次"
sh2.Cells(dd, 11) = "第" & dd & "轮"
sh2.Cells(dd, 12) = bb - 1
Next
End Sub
Sub rnd1()
'VBA直接读EXCEL表原始数据
'可能也就VBA这么干，其他语言应该不直接读excel，而是读xml 或json
Dim sh1 As Object
Set sh1 = ThisWorkbook.Worksheets("data")
c1 = WorksheetFunction.Match("rank", sh1.Range("3:3"), 0)
c2 = WorksheetFunction.Match("ID", sh1.Range("3:3"), 0)
c3 = WorksheetFunction.Match("name", sh1.Range("3:3"), 0)
c4 = WorksheetFunction.Match("num", sh1.Range("3:3"), 0)
c5 = WorksheetFunction.Match("权重", sh1.Range("3:3"), 0)
'希望可以自动识别多行，而不是写死
maxcount1 = sh1.Cells(999, c1).End(xlUp).Row - 3
'方法1：直接读入range()区域，但是和方法2不能同时共存，因为 arr1()不能被重复定义
Dim arr1
'range("") 内部""完全可以字符串拼接，可以按想法随意拼接，还比较自由,但是还是不如 range(cells(),cells())更灵活
' arr1 = sh1.Range("c" & 4 & ":h" & maxcount1 + 3) '拼接成字符串类这个效果即可range("c4:h16")
arr1 = sh1.Range(sh1.Cells(4, c1), sh1.Cells(maxcount1 + 3, 8)) '开始行需要设定，列数也需要设定这个一般较稳定，具体列和最大行数是灵活的
''' '方法2：把range内的数据，按行按列逐个读入数组
''' Dim arr1()
''' For j = 1 To 6 '列相对比较固定，因为列是有意义的，添加需要考虑列的意义
''' For i = 1 To maxcount1 '动态的意义在哪儿，行列都能自动变化 不用改代码，但 range()也可以做到
''' ReDim Preserve arr1(maxcount1, j) '需要用preserve 否则数组只保留最后1个数
''' arr1(i, j) = Application.Index(sh1.Columns(c1 + j - 1), Application.Match(i, sh1.Columns(c1), 0))
''' 'Debug.Print "arr1(" & i & "," & j & ")=" & arr1(i, j)
''' Next
''' Next
'根据原始数据生成一个累积权重数组
Dim arr2()
ReDim arr2(1 To maxcount1)
arr2(1) = arr1(1, 6) '累积权重数组的第一个元素自己特殊处理了
For i = 2 To maxcount1
arr2(i) = arr2(i - 1) + arr1(i, 6)
Next
'开始随机
Randomize
pp0 = Int(1 + (arr2(maxcount1)) * Rnd)
Debug.Print "总权重=" & arr2(maxcount1)
Debug.Print "本次抽到权重pp0=" & pp0
'判断中奖
For i = 1 To maxcount1
If pp0 <= arr2(i) Then
ra1 = arr1(i, 1)
'返回，可根据ra1这个rank返回其他信息
Debug.Print "本次抽中的奖励序号是" & ra1,
Debug.Print "id= " & Application.Index(sh1.Columns(c2), Application.Match(ra1, sh1.Columns(c1), 0)),
Debug.Print "name= " & Application.Index(sh1.Columns(c3), Application.Match(ra1, sh1.Columns(c1), 0)),
Debug.Print "num= " & Application.Index(sh1.Columns(c4), Application.Match(ra1, sh1.Columns(c1), 0))
'这里也可以输出到excel里，本sheet或者其他sheet
Exit For '不加这个中奖后的其他情况也会满足累加判断，所以需要符合即刻跳出
End If
Next
Debug.Print
End Sub
3 代码几个注意点
3.1 循环前变量也需要重置
- 注意新一轮循环开始前，重置关键变量
- 比如循环的判断变量
- 比如计算单轮循环内的计次变量
- 等
3.2 输出区域的清空重置
- 如果输出的区域，每次都是相同区域，每次循环重新开始前，注意对工作区域先重置，必然上次的随机数据污染下轮的结果
- 见上图
3.3 输出多行结果和计数
- 输出到EXCEL，为什么我没写到 抽奖随机循环里，而是写到 do whlie 循环里
- 是因为，do while 多次循环，进行了计次
- 在这里输出，方便按计数输出每次的随机结果
4 如果需要可以调整大奖的权重，怎么修改?
4.1 修改需求
- 现在如果需要，每次抽奖后都给大奖增加一定权重，直至抽到大奖为止
4.2 修改代码
- 修改代码
- 每次抽奖，特殊大奖的权重也要增加，大奖权重= 大奖权重+次数*单次增加权重
- 每次抽奖，总权重就要随着次数增加权重总池子， 总权重= 总权重+次数*单次增加权重
- 这里模拟时，我把大奖权重从110调整为10了，然后每次增加3权重
Private ra1
Private bb
Private ee
Sub super_rnd1()
'为了方便测试，把EXCEL数据里大奖概率调整从10为110了，总权重和还是10000，否则大奖概率太低需要跑很久
Dim sh2
Set sh2 = ThisWorkbook.Worksheets("output1")
'每次都要，先重置输出区域
'可能每次随机模拟次数不同，老的数据只被替换掉一部分造成，污染了新跑的数据，若是写在不同文件就没这问题
sh2.Columns(11).Clear
sh2.Columns(12).Clear
ee = sh2.Cells(2, 17) '每次抽奖增加的权重
ff = sh2.Cells(2, 14) '表上调整测试的轮数
'多轮测试
For i = 1 To ff
'每轮循环开始前重置变量
ra1 = 0
bb = 1
'每次都要，先重置输出区域
sh2.Columns(1).Clear
sh2.Columns(2).Clear
sh2.Columns(3).Clear
sh2.Columns(4).Clear
sh2.Columns(5).Clear
Do Until ra1 = 13 '抽到大奖为止
Call rnd1
Dim sh1 As Object
Set sh1 = ThisWorkbook.Worksheets("data")
c1 = WorksheetFunction.Match("rank", sh1.Range("3:3"), 0)
c2 = WorksheetFunction.Match("ID", sh1.Range("3:3"), 0)
c3 = WorksheetFunction.Match("name", sh1.Range("3:3"), 0)
c4 = WorksheetFunction.Match("num", sh1.Range("3:3"), 0)
c5 = WorksheetFunction.Match("权重", sh1.Range("3:3"), 0)
sh2.Cells(bb, 1) = "第" & bb & "次"
sh2.Cells(bb, 2) = ra1
sh2.Cells(bb, 3) = Application.Index(sh1.Columns(c2), Application.Match(ra1, sh1.Columns(c1), 0)) 'id
sh2.Cells(bb, 4) = Application.Index(sh1.Columns(c3), Application.Match(ra1, sh1.Columns(c1), 0)) 'name
sh2.Cells(bb, 5) = Application.Index(sh1.Columns(c4), Application.Match(ra1, sh1.Columns(c1), 0)) 'num
'统计抽到大奖是第几次
bb = bb + 1
Loop
'统计测试轮数
dd = 1 + dd
Debug.Print "本次抽中大奖是第" & bb - 1 & "次"
sh2.Cells(dd, 11) = "第" & dd & "轮"
sh2.Cells(dd, 12) = bb - 1
Next
End Sub
Sub rnd1()
'VBA直接读EXCEL表原始数据
'可能也就VBA这么干，其他语言应该不直接读excel，而是读xml 或json
Dim sh1 As Object
Set sh1 = ThisWorkbook.Worksheets("data")
c1 = WorksheetFunction.Match("rank", sh1.Range("3:3"), 0)
c2 = WorksheetFunction.Match("ID", sh1.Range("3:3"), 0)
c3 = WorksheetFunction.Match("name", sh1.Range("3:3"), 0)
c4 = WorksheetFunction.Match("num", sh1.Range("3:3"), 0)
c5 = WorksheetFunction.Match("权重", sh1.Range("3:3"), 0)
'希望可以自动识别多行，而不是写死
maxcount1 = sh1.Cells(999, c1).End(xlUp).Row - 3
'方法1：直接读入range()区域，但是和方法2不能同时共存，因为 arr1()不能被重复定义
Dim arr1
'range("") 内部""完全可以字符串拼接，可以按想法随意拼接，还比较自由,但是还是不如 range(cells(),cells())更灵活
' arr1 = sh1.Range("c" & 4 & ":h" & maxcount1 + 3) '拼接成字符串类这个效果即可range("c4:h16")
arr1 = sh1.Range(sh1.Cells(4, c1), sh1.Cells(maxcount1 + 3, 8)) '开始行需要设定，列数也需要设定这个一般较稳定，具体列和最大行数是灵活的
'根据原始数据生成一个累积权重数组
Dim arr2()
ReDim arr2(1 To maxcount1)
arr2(1) = arr1(1, 6) '累积权重数组的第一个元素自己特殊处理了
For i = 2 To maxcount1 - 1
arr2(i) = arr2(i - 1) + arr1(i, 6)
Next
arr2(maxcount1) = arr2(maxcount1 - 1) + arr1(maxcount1, 6) + ee * (bb - 1) '特殊的奖励需要每次增加权重
''' For Each i In arr2
''' Debug.Print i
''' Next
'''
'开始随机
Randomize
pp0 = Int(1 + (arr2(maxcount1) + ee * (bb - 1)) * Rnd) '总权重这里需要增加
Debug.Print "总权重=" & arr2(maxcount1)
Debug.Print "本次抽到权重pp0=" & pp0
'判断中奖
For i = 1 To maxcount1
If pp0 <= arr2(i) Then
ra1 = arr1(i, 1)
'返回，可根据ra1这个rank返回其他信息
Debug.Print "本次抽中的奖励序号是" & ra1,
Debug.Print "id= " & Application.Index(sh1.Columns(c2), Application.Match(ra1, sh1.Columns(c1), 0)),
Debug.Print "name= " & Application.Index(sh1.Columns(c3), Application.Match(ra1, sh1.Columns(c1), 0)),
Debug.Print "num= " & Application.Index(sh1.Columns(c4), Application.Match(ra1, sh1.Columns(c1), 0))
'这里也可以输出到excel里，本sheet或者其他sheet
Exit For '不加这个中奖后的其他情况也会满足累加判断，所以需要符合即刻跳出
End If
Next
Debug.Print
End Sub4.3 改的更复杂一点和随机计算的一些思考
- 按现在的新目标需求再做修改
- 需要根据每次抽奖的次数，增加获得大奖的系统权重，这个权重增加自己中大奖几率，且增加别人的中大奖纪律，大家都能看到。
- 相当于随着抽奖次数增加，更容易抽中大奖
- 需要根据每次抽奖的次数，增加获得大奖的个人权重，这个权重只增加自己中大奖几率，这个自己和别人都不可见，相当于抽的多的人中奖概率更大，但是这个是个潜规则。
先考虑只有系统权重增加的情况
- 虽然中间概率判断，都是 p(rnd) / （p总权重+ 次数*系统权重）
- 但是其实中间概率是变化了的
- 普通奖励因为权重不变，概率下降了 p1= p1权重/（p总权重+ 次数*系统权重）
- 大奖因为权重分子增加，分母也增加，但是分子增加比例更多，概率提高了
- p13= (p13权重+次数*系统权重)/（p总权重+ 次数*系统权重）
- 也就是降低了其他奖励p1-p12的中奖概率，而提高了大奖概率
考虑只有系统权重增加+个人权重增加的情况
- 普通奖励因为权重不变，概率下降了 p1= p1权重/（p总权重+ 次数*系统权重）
- 大奖因为权重分子增加，分母也增加，但是分子增加比例更多，概率提高了
- p13= (p13权重+次数*系统权重+次数*个人权重)/（p总权重+ 次数*系统权重）
- 这个设定，其实可以让p13大奖概率超过100%
下面这个图其实是举例子
如果个人权重增加特别多，每次增加1000，就下图这样了
如果每次增加10000，就很容易超过100%
- 因为是权重变化，而概率= 单权重/ SUM权重
- 看下图
- 受倒影响的分子肯定变化了
- 分母，一般应该也变化的，对应的概率也会变化，而且变化得没有权重这么大
- 但是特殊情况，可以设计概率公式，只分子变化，而分母不变化，这样，概率得变化就会很大，而且可能大于1，就不太符合一般意义得概率了。所以根据实际需求去设计吧。
5 如果需要调整每个奖励的权重，并且权重调整还不同呢
5.1 修改需求
- 可能每个奖项都需要随着抽奖次数增加权重
- 现在把额外的概率写成一个数组了，配合累计权重数组去加和
- 其实甚至可以做成每个奖励 额外增加权重的规则都不同，改改应该也是可以的
主要修改的是这块代码
'用数组标记哪些奖励需要增加权重
'甚至可以标记需要增加多少权重
Dim arr3()
ReDim arr3(1 To maxcount1)
arr3() = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ee) ' array()总是从0开始，干脆让array多一个数，arr3(0)这个数不用它
' arr3() = [{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ee}] '这样不行
'根据原始数据生成一个累积权重数组
Dim arr2()
ReDim arr2(1 To maxcount1)
arr2(1) = arr1(1, 6) + (bb - 1) * arr3(1) '累积权重数组的第一个元素自己特殊处理了
For i = 2 To maxcount1
arr2(i) = arr2(i - 1) + arr1(i, 6) + (bb - 1) * arr3(i)
Next
' arr2(maxcount1) = arr2(maxcount1 - 1) + arr1(maxcount1, 6) + ee * (bb - 1) '特殊的奖励需要每次增加权重，感觉这里写为数组更好把
下面是完整代码
Private ra1
Private bb
Private ee
Sub super_rnd1()
'为了方便测试，把EXCEL数据里大奖概率调整从10为110了，总权重和还是10000，否则大奖概率太低需要跑很久
Dim sh2
Set sh2 = ThisWorkbook.Worksheets("output1")
'每次都要，先重置输出区域
'可能每次随机模拟次数不同，老的数据只被替换掉一部分造成，污染了新跑的数据，若是写在不同文件就没这问题
sh2.Columns(11).Clear
sh2.Columns(12).Clear
ee = sh2.Cells(2, 17) '每次抽奖增加的权重
ff = sh2.Cells(2, 14) '表上调整测试的轮数
'多轮测试
For i = 1 To ff
'每轮循环开始前重置变量
ra1 = 0
bb = 1
'每次都要，先重置输出区域
sh2.Columns(1).Clear
sh2.Columns(2).Clear
sh2.Columns(3).Clear
sh2.Columns(4).Clear
sh2.Columns(5).Clear
Do Until ra1 = 13 '抽到大奖为止
Call rnd1
Dim sh1 As Object
Set sh1 = ThisWorkbook.Worksheets("data")
c1 = WorksheetFunction.Match("rank", sh1.Range("3:3"), 0)
c2 = WorksheetFunction.Match("ID", sh1.Range("3:3"), 0)
c3 = WorksheetFunction.Match("name", sh1.Range("3:3"), 0)
c4 = WorksheetFunction.Match("num", sh1.Range("3:3"), 0)
c5 = WorksheetFunction.Match("权重", sh1.Range("3:3"), 0)
sh2.Cells(bb, 1) = "第" & bb & "次"
sh2.Cells(bb, 2) = ra1
sh2.Cells(bb, 3) = Application.Index(sh1.Columns(c2), Application.Match(ra1, sh1.Columns(c1), 0)) 'id
sh2.Cells(bb, 4) = Application.Index(sh1.Columns(c3), Application.Match(ra1, sh1.Columns(c1), 0)) 'name
sh2.Cells(bb, 5) = Application.Index(sh1.Columns(c4), Application.Match(ra1, sh1.Columns(c1), 0)) 'num
'统计抽到大奖是第几次
bb = bb + 1
Loop
'统计测试轮数
dd = 1 + dd
Debug.Print "本次抽中大奖是第" & bb - 1 & "次"
sh2.Cells(dd, 11) = "第" & dd & "轮"
sh2.Cells(dd, 12) = bb - 1
Next
End Sub
Sub rnd1()
'VBA直接读EXCEL表原始数据
'可能也就VBA这么干，其他语言应该不直接读excel，而是读xml 或json
Dim sh1 As Object
Set sh1 = ThisWorkbook.Worksheets("data")
c1 = WorksheetFunction.Match("rank", sh1.Range("3:3"), 0)
c2 = WorksheetFunction.Match("ID", sh1.Range("3:3"), 0)
c3 = WorksheetFunction.Match("name", sh1.Range("3:3"), 0)
c4 = WorksheetFunction.Match("num", sh1.Range("3:3"), 0)
c5 = WorksheetFunction.Match("权重", sh1.Range("3:3"), 0)
'希望可以自动识别多行，而不是写死
maxcount1 = sh1.Cells(999, c1).End(xlUp).Row - 3
'方法1：直接读入range()区域，但是和方法2不能同时共存，因为 arr1()不能被重复定义
Dim arr1
'range("") 内部""完全可以字符串拼接，可以按想法随意拼接，还比较自由,但是还是不如 range(cells(),cells())更灵活
' arr1 = sh1.Range("c" & 4 & ":h" & maxcount1 + 3) '拼接成字符串类这个效果即可range("c4:h16")
arr1 = sh1.Range(sh1.Cells(4, c1), sh1.Cells(maxcount1 + 3, 8)) '开始行需要设定，列数也需要设定这个一般较稳定，具体列和最大行数是灵活的
'用数组标记哪些奖励需要增加权重
'甚至可以标记需要增加多少权重
Dim arr3()
ReDim arr3(1 To maxcount1)
arr3() = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ee) ' array()总是从0开始，干脆让array多一个数，arr3(0)这个数不用它
' arr3() = [{0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, ee}] '这样不行
'根据原始数据生成一个累积权重数组
Dim arr2()
ReDim arr2(1 To maxcount1)
arr2(1) = arr1(1, 6) + (bb - 1) * arr3(1) '累积权重数组的第一个元素自己特殊处理了
For i = 2 To maxcount1
arr2(i) = arr2(i - 1) + arr1(i, 6) + (bb - 1) * arr3(i)
Next
' arr2(maxcount1) = arr2(maxcount1 - 1) + arr1(maxcount1, 6) + ee * (bb - 1) '特殊的奖励需要每次增加权重，感觉这里写为数组更好把
'开始随机
Randomize
pp0 = Int(1 + (arr2(maxcount1) + ee * (bb - 1)) * Rnd) '总权重这里需要增加
Debug.Print "总权重=" & arr2(maxcount1)
Debug.Print "本次抽到权重pp0=" & pp0
'判断中奖
For i = 1 To maxcount1
If pp0 <= arr2(i) Then
ra1 = arr1(i, 1)
'返回，可根据ra1这个rank返回其他信息
Debug.Print "本次抽中的奖励序号是" & ra1,
Debug.Print "id= " & Application.Index(sh1.Columns(c2), Application.Match(ra1, sh1.Columns(c1), 0)),
Debug.Print "name= " & Application.Index(sh1.Columns(c3), Application.Match(ra1, sh1.Columns(c1), 0)),
Debug.Print "num= " & Application.Index(sh1.Columns(c4), Application.Match(ra1, sh1.Columns(c1), 0))
'这里也可以输出到excel里，本sheet或者其他sheet
Exit For '不加这个中奖后的其他情况也会满足累加判断，所以需要符合即刻跳出
End If
Next
Debug.Print
End Sub