20170528xlVBA凑数一例

Posted 2020-09-27 Excel VBA 小天地

Public Sub MakeUp()
 
    Dim Sht As Worksheet
    Set Sht = ThisWorkbook.Worksheets("设置")
    Dim Total As Double
    Dim iMin As Double, iMax As Double
    Dim RndNum As Long
    Dim RndRow As Long
    Dim Index As Long
    With Sht
        Application.Intersect(.Range("C:C"), .UsedRange.Offset(1)).ClearContents
        Total = .Range("B2").Value
        iMin = .Range("B3").Value
        iMax = .Range("B4").Value
        Index = 1
        ‘初次分配
        Do While Total > iMax
            Index = Index + 1
            RndNum = iMin + Rnd() * (iMax - iMin)
            .Cells(Index, 3).Value = RndNum
            Total = Total - RndNum
        Loop

        ‘产生剩余

        If Total >= iMin Then
            .Range("B5").Value = Index
            Index = Index + 1
            .Cells(Index, 3).Value = Total
        Else
            ‘剩余不足2900的 再次随机分配
            Do While Total > 0
                RndRow = Rnd() * (Index - 2) + 2
                Delta = iMax - .Cells(RndRow, 3).Value
                If Total > Delta Then
                    RndNum = Rnd() * (Delta)    ‘保证不会超过3500
                    .Cells(RndRow, 3).Value = .Cells(RndRow, 3).Value + RndNum
                    Total = Total - RndNum
                Else
                    .Cells(RndRow, 3).Value = .Cells(RndRow, 3).Value + Total
                    Total = 0
                End If
            Loop
             .Range("B5").Value = Index
        End If
           ‘If Now > #10/1/2017# Then Application.Intersect(.Range("C:C"), .UsedRange.Offset(1)).ClearContents
    End With
    Set Sht = Nothing
End Sub