|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
【需求】
人员min已有多个数据总值,现在需要根据已有的值将其随机拆分至不同的产品/部门/品牌等维度,数据值类型可能包含小数点/文本/负数/整数。
【分析】
1.如果直接用随机区间去截取数据会产生一个问题,即随机的数据产生会集中在前面的几列,而后续的列的值基本全部变为0,有自己写过的人有亲身体会。所以为了解决这个问题,需要根据拆分的组数对每个随机数的上限进行二次约束。
2.负数进行随机拆解的问题,如果用randbettwen方法需要注意传入的参数始终保持左小又大;
3.小数点的问题,可以先对它进行放大后再操作
4.解决分组数量动态变化的问题,起一个参数表,读取后作为分组数量即可
【代码】
1.主程序
Sub genRandomNum()
t_1 = Timer
arr = Sheets("随机分配").[a1].CurrentRegion
ars = Sheets("参数设置").[a1].CurrentRegion
If UBound(arr, 2) > 1 Then
Sheets("随机分配").Range(Sheets("随机分配").Cells(1, 2), Sheets("随机分配").Cells(UBound(arr), UBound(arr, 2))).ClearContents
End If
'解决生成的随机数主要集中在前面的几个维度的问题
If UBound(ars) <= 3 Then
k = 1
Else
If UBound(ars) <= 6 Then
k = 0.4
Else
k = 2 / (UBound(ars) - 2)
End If
End If
Dim rData
ReDim rData(1 To UBound(arr), 1 To UBound(ars) - 1)
For j = 2 To UBound(ars)
rData(1, j - 1) = ars(j, 1)
Next j
For i = 2 To UBound(arr)
If IsNumeric(arr(i, 1)) = True Then
If arr(i, 1) = 0 Then
For j = 2 To UBound(ars)
rData(i, j - 1) = 0
Next j
Else
If arr(i, 1) > 0 Then
syn = 1
Else
arr(i, 1) = -arr(i, 1)
syn = -1
End If
rateVal = 10 ^ handleDigitalNum(arr(i, 1))
arr(i, 1) = arr(i, 1) * rateVal
t = arr(i, 1)
m = 0
For j = 2 To UBound(ars) - 1
rData(i, j - 1) = arr(i, 1)
While rData(i, j - 1) / arr(i, 1) > k
rData(i, j - 1) = WorksheetFunction.RandBetween(0, arr(i, 1) - m)
Wend
m = m + rData(i, j - 1)
t = t - m
Next j
rData(i, UBound(ars) - 1) = (arr(i, 1) - m)
For j = 2 To UBound(ars)
rData(i, j - 1) = rData(i, j - 1) * syn / rateVal
Next j
End If
On Error Resume Next
End If
Next i
Sheets("随机分配").Cells(1, 2).Resize(UBound(arr), UBound(ars) - 1) = rData
t_2 = Timer
MsgBox "运行成功!RunTime:" & Round(t_2 - t_1, 2) & "s." & vbCrLf & "Program Designed By Apollo_Chen On 2022/10/29." & vbCrLf & "For MinMinMin Only!", vbOKOnly, "Lovely.Min"
End Sub
2.处理小数点的函数
Function handleDigitalNum(num) '解决小数点的问题
If InStr(1, Str(num), ".") > 0 Then
arrNum = Split(Str(num), ".")
n = Len(arrNum(1))
Else
n = 0
End If
handleDigitalNum = n
End Function
【运行结果示例】
示例
|
评分
-
2
查看全部评分
-
|