数值分配问题

Question

如果把表格二中的"数量"按照表格一中的应占有量分配给不同的人，并把表格一的名字写到表格二的已分配列。应占有量的总和不一定是固定在100%，可以有+/-6%的波动。表格一名字 应占有量
张三 14%
李四 26%
王五 33%
陈六 10%
刘七 17%表格二序列号 数量 已分配给
1 7.4384
2 7.4384
3 24.1007
4 24.1007
5 5.4774
6 5.4774
7 7.3796
8 7.3796
9 11.1375
10 11.1375
11 10.9
12 10.9
13 10.0651
14 10.0651
15 4.0972
16 4.0972
17 16.3497
18 16.3497
19 25.5913
20 7.6939
21 9.1466
22 5.0664

Answer 1

不知道理解的对不对，你试试吧
Sub Assign()
    Dim d As Object, d2 As Object
    Dim S1 As Worksheet, S2 As Worksheet
    Dim TotalRow1 As Long, TotalRow2 As Long, CurRow As Long
    Dim Total As Single
    Set d = CreateObject("Scripting.Dictionary")
    'Set d2 = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets(1)
    Set S2 = Sheets(2)
    TotalRow1 = S1.[A65535].End(xlUp).Row
    TotalRow2 = S2.[A65535].End(xlUp).Row
    For CurRow = 2 To TotalRow1
        d(S1.Cells(CurRow, 1).Value) = Val(S1.Cells(CurRow, 2))
        'd2(S1.Cells(CurRow, 1).Value) = 0#
    Next CurRow
    For CurRow = 2 To TotalRow2
        Total = Total + S2.Cells(CurRow, 2)
    Next CurRow
    Dim i As Long
    For CurRow = 2 To TotalRow2
        For i = 2 To d.Count + 1
            If S2.Cells(CurRow, 2) / Total < d(S1.Cells(i, 1).Value) + 0.01 Then
                S2.Cells(CurRow, 3) = S1.Cells(i, 1)
                d(S1.Cells(i, 1).Value) = d(S1.Cells(i, 1).Value) - S2.Cells(CurRow, 2) / Total
                'd2(S1.Cells(i, 1).Value) = d2(S1.Cells(i, 1).Value) + S2.Cells(CurRow, 2) / Total
                Exit For
            End If
        Next i
    Next CurRow
    For CurRow = 2 To TotalRow1
        'S1.Cells(CurRow, 3) = d2(S1.Cells(CurRow, 1).Value)
    Next CurRow
End Sub被注释掉的代码是计算分配后每个人实际的占用量

Answer 2

避免李四占有所有的分配量？我有点糊涂了，如果是按比例分配，不会出现这种现象呀现在按照这个要求“在每次分配循环结束把已得到数值的人移到后面”将程序做了修改，不知道理解的对不对
Sub Assign()
    Dim d As Object
    Dim S1 As Worksheet, S2 As Worksheet
    Dim TotalRow1 As Long, TotalRow2 As Long, CurRow As Long
    Dim Total As Single
    Dim Person() As String
    Set d = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets(1)
    Set S2 = Sheets(2)
    TotalRow1 = S1.[A65535].End(xlUp).Row   '表1的总行数
    TotalRow2 = S2.[A65535].End(xlUp).Row   '表2的总行数
    ReDim Person(TotalRow1) As String
    For CurRow = 2 To TotalRow1
        d(S1.Cells(CurRow, 1).Value) = Val(S1.Cells(CurRow, 2))
        Person(CurRow - 1) = Cells(CurRow, 1)   '将分配人员动态存储
    Next CurRow
    For CurRow = 2 To TotalRow2
        Total = Total + S2.Cells(CurRow, 2)     '总任务数
    Next CurRow
    Dim i As Long, j As Long
    For CurRow = 2 To TotalRow2
        For i = 2 To d.Count + 1
            If S2.Cells(CurRow, 2) / Total < d(Person(i - 1)) + 0.01 Then   '如果此任务小于某人的剩余份额，则将该任务分配给此人
                S2.Cells(CurRow, 3) = S1.Cells(i, 1)
                d(Person(i - 1)) = d(Person(i - 1)) - S2.Cells(CurRow, 2) / Total   '计算此人的剩余份额
                Person(0) = Person(i - 1)           '将此人移至最后
                For j = i - 1 To TotalRow1 - 2
                    Person(j) = Person(j + 1)
                Next j
                Person(TotalRow1 - 1) = Person(0)
                Exit For
            End If
        Next i
    Next CurRow
    For CurRow = 2 To TotalRow1
        S1.Cells(CurRow, 3) = S1.Cells(CurRow, 2) - d(S1.Cells(CurRow, 1).Value)        '显示实际分配额
    Next CurRow
End Sub

Answer 3

不好意思，程序有点小问题，改了一下：
Sub Assign()
    Dim d As Object
    Dim S1 As Worksheet, S2 As Worksheet
    Dim TotalRow1 As Long, TotalRow2 As Long, CurRow As Long
    Dim Total As Single
    Dim Person() As String
    Set d = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets(1)
    Set S2 = Sheets(2)
    TotalRow1 = S1.[A65535].End(xlUp).Row   '表1的总行数
    TotalRow2 = S2.[A65535].End(xlUp).Row   '表2的总行数
    ReDim Person(TotalRow1 - 1) As String
    For CurRow = 2 To TotalRow1
        d(S1.Cells(CurRow, 1).Value) = Val(S1.Cells(CurRow, 2))
        Person(CurRow - 1) = S1.Cells(CurRow, 1)   '将分配人员动态存储
    Next CurRow
    For CurRow = 2 To TotalRow2
        Total = Total + S2.Cells(CurRow, 2)     '总任务数
    Next CurRow
    Dim i As Long, j As Long
    For CurRow = 2 To TotalRow2
        For i = 2 To d.Count + 1
            If S2.Cells(CurRow, 2) / Total < d(Person(i - 1)) + 0.01 Then   '如果此任务小于某人的剩余份额，则将该任务分配给此人
                S2.Cells(CurRow, 3) = Person(i - 1)
                d(Person(i - 1)) = d(Person(i - 1)) - S2.Cells(CurRow, 2) / Total   '计算此人的剩余份额
                Person(0) = Person(i - 1)           '将此人移至最后
                For j = i - 1 To TotalRow1 - 2
                    Person(j) = Person(j + 1)
                Next j
                Person(TotalRow1 - 1) = Person(0)
                Exit For
            End If
        Next i
    Next CurRow
    For CurRow = 2 To TotalRow1
        S1.Cells(CurRow, 3) = S1.Cells(CurRow, 2) - d(S1.Cells(CurRow, 1).Value)        '显示实际分配额
    Next CurRow
End Sub
分配结果如下：
名字 应占有量 实际占有量
张三 14% 0.141341755
李四 26% 0.244108493
王五 33% 0.336449752
陈六 10% 0.099841588
刘七 17% 0.178258457
序列号 数量 已分配给
1 7.4384 张三
2 7.4384 李四
3 24.1007 王五
4 24.1007 陈六
5 5.4774 刘七
6 5.4774 张三
7 7.3796 李四
8 7.3796 王五
9 11.1375 刘七
10 11.1375 张三
11 10.9 李四
12 10.9 王五
13 10.0651 刘七
14 10.0651 张三
15 4.0972 李四
16 4.0972 王五
17 16.3497 刘七
18 16.3497 李四
19 25.5913 王五
20 7.6939 李四
21 9.1466 王五
22 5.0664 李四