将一个数随机分成多个数

china047

各位老师:
            如何用VBA将一个总数分成7数随机(最小的为40,最大的为43),可以重复,但不能全部一样!

有条件分配随机数.rar (6.3 KB, 下载次数: 7)

2024-10-30 21:00 上传

点击文件名下载附件

fjlhgs

    Dim i As Long, j As Long, n As Long, v As Double
    n = Cells(2, 1)
    For i = 1 To 6
        Do
            Randomize
            j = 40 + Int(Rnd() * 4)
            v = (n - j) / (7 - i)
            If v > 40 And v < 43 Then
               Cells(3, i + 1) = j
               n = n - j
               Exit Do
            End If
        Loop
    Next
    Cells(3, 8) = n

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, t#
    t = Timer
    ar = rndNumIsTotalSum(40, 43, 7, [A2].Value)
    [B2].Resize(, UBound(ar)) = ar
End Sub

Function rndNumIsTotalSum(ByVal iMinNum&, ByVal iMaxNum&, ByVal iCount&, ByVal iSumNum&)
    Dim ar(), i&, iAverage&, iRnd1&, iRnd2&, iRndNum&, iBal1&, iBal2&

    ReDim ar(1 To iCount)
    iAverage = Int(iSumNum / iCount)
    If iAverage < iMinNum Or iAverage > iMaxNum Then
        For i = 1 To UBound(ar): ar(i) = "无解！": Next
        rndNumIsTotalSum = ar: Exit Function
    End If
    For i = 1 To UBound(ar)
        ar(i) = iAverage
    Next i
    For i = 1 To (iSumNum - iAverage * iCount)
        ar(i) = ar(i) + 1
    Next i
   
    Randomize
    For i = 1 To iCount
        iRnd1 = Int(iCount * Rnd + 1): iRnd2 = Int(iCount * Rnd + 1)
        iBal2 = iMaxNum - ar(iRnd2): iBal1 = ar(iRnd1) - iMinNum
        If iBal2 < iBal1 Then iRndNum = iBal2 Else iRndNum = iBal1
        ar(iRnd1) = ar(iRnd1) - iRndNum
        ar(iRnd2) = ar(iRnd2) + iRndNum
    Next i
    rndNumIsTotalSum = ar
End Function

gwjkkkkk

请参考。。。

yynrzwh

Sub test()

s = 290 '总数
m = 40 '最小值
n = 43 '最大值
Dim ar(6)

For i = 0 To 6
    ar(i) = m
Next
VBA.Randomize
y = s - m * 7
Do While y > 0
    x = Int(Rnd * 7)
    If ar(x) < n Then
        ar(x) = ar(x) + 1
        y = y - 1
    End If
Loop

Range("b2").Resize(1, 7) = ar

End Sub

china047

fjlhgs 发表于 2024-10-30 22:16
Dim i As Long, j As Long, n As Long, v As Double
    n = Cells(2, 1)
    For i = 1 To 6

非常感谢！

china047

yynrzwh 发表于 2024-10-31 20:38
Sub test()

s = 290 '总数

非常感谢

china047

gwjkkkkk 发表于 2024-10-31 18:15
Option Explicit
Sub test()
    Dim ar, t#

非常感谢！