取整平均分配-不尽取舍问题-VBA

1. 使用场景:

   1. 简单场景:5个苹果分给三个人,多的两个随机分配
   2. 进阶场景:20个苹果分给三个团队,三个团队一共8个人,分别是3,4,1,按照人头比例尽可能公平分配,一人应分得20/8=2.5个苹果,3人团分的2.5*3=7.5个,4人团10个,1人团2.5个,随机将3人团分为8个,1人团1个.
   3. 高级场景:假设有20个团队，每个团人数不一样，按照人数的多少给团队分配有限的苹果，并且不止有一种类型苹果，有苹果1号品种，2号品种……，做到不多不缺，各类苹果都尽可能公平分配。

2. 分配思路:

   1. 已知各类苹果数量，各团队名称和数量

   2. 计算出按照人数分配的基础数量，某团队的基础分配数量=某类苹果总数/所有团队人数*某团队人数，四舍五入保留整数

   3. 计算出各类苹果下的各团队和基础分配数量总和和实际各类苹果的总数，可能实际苹果数量要多2个，或者3个。

   4. 将多余或者缺少到苹果数量依次从上到下从每个团队基础数量上添加或减少一个，是的最终分配数量刚好等于实际苹果数量

3. 案例

现在老板给了你一个项目,告诉你今天的存量是如下: 称其为[存量]

比如深圳有260个客户,广州有16个客户

比如目前有这么几个团队和人数:

老板说你按照人数多少分给他们客户量,差不多平均就行

首先按照渠道的存量/所有团队总数,四舍五入取整获得基础分配量,称其为[基础分配量]

然后在建一个表,按照这个表头和总计(红线框的),不限制团队数量和苹果种类数量,将sheet命名为[最终分配量],将鼠标箭头放在这个表内,Alt + F8（调出宏），选任一工作表，右键插入【模块】，复制下来代码 粘贴,即可自动分配(自上而下)

结果展示:

操作步骤

1、Alt + F8（调出宏），选任一工作表，右键插入【模块】，复制下来代码 粘贴

2、将工作表和名字和位置与图片中一样相对应

3、点击运行即可

代码运行逻辑

1. 在基础分配量上,给几个人加或者减多余的个数,
2. area 就是苹果种类区域,比如5号区域,range就是5号下的单元格,
3. a 就是缺量或者余量,有2个多余的苹果,就做给前几个单元格减+1,缺也是一样,这里写个函数,正数返回+1,负数返回-1

复制代码

Function GetSign(ByVal num As Double) As Integer
If num > 0 Then
GetSign = 1 ' 正数返回1
ElseIf num < 0 Then
GetSign = -1 ' 负数返回-1
Else
GetSign = 0 ' 零返回0
End If
End Function
Sub 不尽取舍()
Dim j, targetRange As Range
Dim Start_column%, Stop_column%, Stop_row%, n%, q%, a%, i%
Dim Ftable, Btable As Worksheet  ' Final_table As Worksheet, Base_quantity_table As Worksheet


Set Ftable = Worksheets("最终分配量")
Set Btable = Worksheets("基础分配量")

Start_column = 3 '第一种苹果开始列数
Stop_column = Ftable.UsedRange.Columns.Count '最后一种苹果结束列数
Stop_row = Ftable.UsedRange.Rows.Count  '行数,除去最后总计


For n = Start_column To Stop_column '循环列数-area
    
    q = Worksheets("存量").Cells(2, n).Value - Btable.Cells(Stop_row, n).Value '计算余量或缺量
    a = Abs(q) '前a个单元格会被改变
    Set targetRange = Range(Cells(2, n), Cells(Stop_row - 1, n)) '第n列的基础分配量区域
    i = 0
        For Each j In targetRange '第n列的基础分配量区域的依次单元格-range
            If a = 0 Or i >= a Then
                Ftable.Cells(j.Row, j.Column).Value = Btable.Cells(j.Row, j.Column).Value
            Else '达到分配次数就按照基础量
                i = i + 1
                Ftable.Cells(j.Row, j.Column).Value = Btable.Cells(j.Row, j.Column).Value + GetSign(q)
            End If
        Next j '
Next n '

End Sub