[已解决]微信，qq红包随机问题怎么用excel模拟

苏子龙 · 发表于 2017-9-25 15:15

如10元发5个包，5个是随机数的带2位小数，总和等于10元，用函数，vba或者power query等不限制方法

最佳答案

月排行榜 / 总排行榜

小新De和尚头

2017-9-25 17:15

本帖最后由小新De和尚头于 2017-9-25 17:30 编辑

Sub GetRandomMoney(r As RedPackage)
For i = 1 To r.remainSize
If r.remainSize = 1 Then
r.remainSize = r.remainSize - 1
Debug.Print Round(r.remainMoney * 100) / 100
Exit Sub
End If
Dim min As Double
Dim max As Double
Dim money As Double
min = 0.01
max = r.remainMoney / r.remainSize * 2
Randomize
money = Rnd * max
If money <= min Then
money = 0.01
End If
money = Fix(money * 100) / 100
r.remainSize = r.remainSize - 1
r.remainMoney = r.remainMoney - money
Debug.Print money
Next
End Sub
Sub test()
Dim r As New RedPackage
r.remainMoney = 1
r.remainSize = 3
Call GetRandomMoney(r)
'结果请在立即窗口里查看
End Sub

复制代码

测试结果：

跳转到最佳答案楼层

大灰狼1976 · 发表于 2017-9-25 15:30

不玩微信，不知道对不对。

Sub aaa()
Dim n#, arr(1 To 5), i&, m#
Randomize
n = 10
For i = 1 To 4
m = Format(Rnd() * n, "0.00")
arr(i) = m
n = n - m
Next i
arr(5) = n
[a1].Resize(, 5) = arr
End Sub

复制代码

苏子龙 · 发表于 2017-9-25 16:41

本帖最后由苏子龙于 2017-9-26 08:30 编辑

Sub RedPackage()
Dim ar(), SumHe#, i%, n%, TemCount
Dim RedPkgMoney#, RedPkgCount%, TemMaxMoney%
RedPkgMoney = [c2]: RedPkgCount = [d2] '初始化，提取红包数据并判断
If RedPkgMoney = 0 Or RedPkgCount = 0 Then Exit Sub
If RedPkgMoney > 200 Then MsgBox "最大200元": Exit Sub
If RedPkgCount > 100 Then MsgBox "最多发100个": Exit Sub
If RedPkgMoney / RedPkgCount < 0.01 Then MsgBox "最少发0.01元": Exit Sub
ReDim ar(1 To RedPkgCount, 1 To 3) '定义数组，1是随机金额，2辅助排序，3最后的金额
For i = 1 To RedPkgCount - 1 '循环数量-1
TemCount = Int(Rnd * (RedPkgCount - i - 1)) + 1 '随机分多少次
TemMaxMoney = RedPkgMoney * 100 - SumHe * 100 - RedPkgCount + i '随机临时本次最大金额
TemMaxMoney = Int(TemMaxMoney / TemCount) '再随机取最大金额
TemMaxMoney = IIf(TemMaxMoney < 1, 1, TemMaxMoney) '判断：最少分的0.01元
ar(i, 1) = Application.RandBetween(1, TemMaxMoney) / 100 '随机金额
SumHe = ar(i, 1) + SumHe '已分金额总计
Next
ar(RedPkgCount, 1) = RedPkgMoney - SumHe '最后分的金额
i = 1 '用do，loop循环，已分金额再随机排序
Do While i <= RedPkgCount
n = Int(Rnd * RedPkgCount) + 1
If ar(n, 2) = "" Then
ar(n, 2) = n
ar(i, 3) = ar(n, 1)
i = i + 1
End If
Loop
Range("a:a").ClearContents
Range("a1").Resize(RedPkgCount, 1) = Application.Index(ar, , 3)
End Sub

复制代码

常规想法做的vba

小新De和尚头 · 发表于 2017-9-25 17:15

本帖最后由小新De和尚头于 2017-9-25 17:30 编辑

Sub GetRandomMoney(r As RedPackage)
For i = 1 To r.remainSize
If r.remainSize = 1 Then
r.remainSize = r.remainSize - 1
Debug.Print Round(r.remainMoney * 100) / 100
Exit Sub
End If
Dim min As Double
Dim max As Double
Dim money As Double
min = 0.01
max = r.remainMoney / r.remainSize * 2
Randomize
money = Rnd * max
If money <= min Then
money = 0.01
End If
money = Fix(money * 100) / 100
r.remainSize = r.remainSize - 1
r.remainMoney = r.remainMoney - money
Debug.Print money
Next
End Sub
Sub test()
Dim r As New RedPackage
r.remainMoney = 1
r.remainSize = 3
Call GetRandomMoney(r)
'结果请在立即窗口里查看
End Sub

复制代码

测试结果：

苏子龙 · 发表于 2017-9-26 13:16

结合2，4楼的代码
Sub aaa()
Dim Money As Double, arr(), iCount As Integer 'money是余额，arr存放分得的金额,icount是循环数
Dim TemMoney As Double, Max As Double 'temmoney随机金额，max是可以分的最大金额
Const Min As Double = 0.01 '定义常量：最小额
Dim RedPackageMoney As Double, RedPackageCount As Integer '红包金额和个数

RedPackageMoney = Range("C2").Value
RedPackageCount = Range("D2").Value
If RedPackageMoney > 200 Then MsgBox "金额不能大于200元": Exit Sub
If RedPackageCount > 100 Then MsgBox "红包个数不能大于100个": Exit Sub
If RedPackageMoney / RedPackageCount < Min Then MsgBox "输入不对": Exit Sub
ReDim arr(1 To RedPackageCount, 1 To 1)
Money = RedPackageMoney '初始将红包里的钱放入money,作为剩余金额
Randomize
For iCount = 1 To RedPackageCount '循环判断
      If iCount = RedPackageCount Then '当最后一个时，就运行最后一步
         arr(iCount, 1) = Application.Round(Money, 2)
         Range("a:a").ClearContents
         Range("a1").Resize(RedPackageCount) = arr
         Exit Sub
      End If
      Max = Money / (RedPackageCount - iCount + 1) * 2 '平分
      TemMoney = Fix(Rnd * Max * 100) / 100    '随机取值，fix同int
      If TemMoney < Min Then TemMoney = Min  '当小于最小值时，取最小值
      arr(iCount, 1) = TemMoney
      Money = Money - TemMoney       '累计剩余金额
Next iCount
End Sub

苏子龙 · 发表于 2017-9-26 16:16

本帖最后由苏子龙于 2017-9-26 16:28 编辑

Dim Je As Double, Ncount As Integer, arr(1 To 100)
Sub test()
Dim RedPackageMoney As Double, RedPackageCount As Integer '红包金额和个数
RedPackageMoney = Range("C2").Value
RedPackageCount = Range("D2").Value
If RedPackageMoney > 200 Then MsgBox "金额不能大于200元": Exit Sub
If RedPackageCount > 100 Then MsgBox "红包个数不能大于100个": Exit Sub
If RedPackageMoney / RedPackageCount < Min Then MsgBox "输入不对": Exit Sub
Ncount = RedPackageCount
Je = RedPackageMoney
Call digui(Je)
Range("a:a").ClearContents
Range("a1").Resize(RedPackageCount) = Application.Transpose(arr)
End Sub
Sub digui(M)
Dim max As Double
max = Je / Ncount * 2
max = Int(Rnd * max * 100) / 100
If max < 0.01 Then max = 0.01
If Ncount = 1 Then '退出条件***
arr(Ncount) = Application.Round(Je, 2)
Exit Sub
End If
arr(Ncount) = max
Je = Je - max
Ncount = Ncount - 1
Call digui(Je)
End Sub

复制代码

学习递归，用递归替代for，next循环

hhzjxss · 发表于 2017-9-27 17:10

说了这么久，红包呢，在哪里呀

苏子龙 · 发表于 2017-9-28 13:49

hhzjxss 发表于 2017-9-27 17:10
说了这么久，红包呢，在哪里呀

{:011:}加qq群后才能发吧

苏子龙 · 发表于 2017-9-28 15:47

今天搬来了江苏大侠的函数公式

=IF(ROW()<C7+8,IFERROR(FREQUENCY(ROW(INDIRECT("1:"&C8/1%-C7)),RANDBETWEEN(ROW(INDIRECT("1:"&C7-1))*0,C8/1%-C8)),)%+1%,"")

复制代码

具体见附件

苏子龙 · 发表于 2017-9-28 16:10

本帖最后由苏子龙于 2017-9-28 16:21 编辑

上面函数，如果是一个包时，会出错，就再加个判断

=IF(ROW()<C7+8,IF(C7=1,C8,IFERROR(FREQUENCY(ROW(INDIRECT("1:"&C8/1%-C7)),RANDBETWEEN(ROW(INDIRECT("1:"&C7-1))*0,C8/1%-C8)),)%+1%),"")

复制代码

其原理是用到了frequency函数的特性，fre。是取数的频率次数，如只有3个数时
=frequency(row(1:10),｛2，5｝),其结果是｛2,3,5｝，正好是要的金额,2,5位置不同结果位置跟着变，但结果的和还是10
本例中fre第一参数ROW(INDIRECT("1:"&C8/1%-C7))，金额放大100倍，就是金额变成整数，减个数就是减1分钱，后面再加上1分钱，总数不变，而且为了防止错误时起码还有1分钱存在
fre。第二参数是用randbetween去个数-1的随机数（0~金额*100-金额),减金额是防止正好随机到最大数。

		自动登录	找回密码
密码			注册

[已解决]微信，qq红包随机问题怎么用excel模拟

评分

评分