求助大佬，如何按比例分配人员或按比例填充

106102

各位大佬，小弟求助一件事项，现有要求100个金额数组，要求按比例分配给AB

要求每个人手里有大额金额和小额金额，参考分配：
比如：A和B 各分配百分之50%      则排序填充顺序为：A-B-B-A（因为分配金额相对平均）   最后各分配50件，金额也各占总金额50%

请大佬帮忙协助：输入A的比例（2-49%区间即可），可以生成对应比例的数量，并在分配栏进行填充，最后分配到的金额也和比例相对一致（可以有1-5%的误差，不需要完全按照比例）
以上，感谢！






分配.zip (19.96 KB, 下载次数: 8)

2022-6-4 03:18 上传

点击文件名下载附件

106102

类似效果：https://www.bilibili.com/video/BV1Ga411F7jo，此案例可以平均分配，但是无法达成金额和 比例相对一致

不一定按以上的分配实例分配，达到金额和比例差不多即可（1-5%的误差）

106102

求大佬解答！！

hasyh2008

没搞懂意思

106102

hasyh2008 发表于 2022-6-11 07:17
没搞懂意思

就是假设有100个订单，按要求的比例分配给A和B，要求分配后的订单金额也和比例相同
比如A和B各百分之50，就是2人各分得50件订单，2个人各分得50件订单后的总金额也要和比例相等（可以有1-5%的误差）

hasyh2008

Sub tt()
    Dim Arr, Brr(), Rc%, K%, X%, Y%, Num, Str$, I%
    Dim Gs%, Avg As Single, T As Single
    T = Timer
    With ActiveSheet
        Rc = .Range("A1").CurrentRegion.Rows.Count
        .Range("B2").Resize(Rc - 1, 2) = ""
        Arr = .Range("A2:A" & Rc)
        Gs = Int(UBound(Arr) * .Cells(2, 6))
        Avg = Application.Average(Arr)
        ReDim Brr(1 To Gs)
        I = 0
100:
        For X = 1 To Gs
            Rc = UBound(Arr) - X + 1
            K = Int(Rnd() * Rc) + 1
            Brr(X) = Arr(K, 1)
            Num = Arr(Rc, 1)
            Arr(Rc, 1) = Arr(K, 1)
            Arr(K, 1) = Num
        Next X
        If Application.Average(Brr) / Avg > 0.999 And Application.Average(Brr) / Avg < 1.001 Then
            .Cells(2, 1).Resize(Gs) = Application.Transpose(Brr)
            .Cells(2, 2).Resize(Gs) = "A"
            .Cells(Gs + 2, 1).Resize(UBound(Arr) - Gs) = Arr
            .Cells(Gs + 2, 2).Resize(UBound(Arr) - Gs) = "B"
            MsgBox "已分配完毕！"
            MsgBox "运行次数：" & I + 1
            MsgBox "用时：" & Format(Timer - T, "0.00")
            Exit Sub
        Else
            I = I + 1
            GoTo 100
        End If
    End With
End Sub