MACRO 自动平均分配工作

robinzzy · 发表于 2014-8-14 16:37

香川群子发表于 2014-8-14 16:21
上一下1000单的附件。

把公司名称替换为Company01、Company02……或公司-1、公司-2

您好，我付了一张200单的附件，由10个公司组成，已照您的要求改了，希望可以用来写code了
谢谢您了！！！！

举例.rar (19.97 KB, 下载次数: 9)

yjh_27 · 发表于 2014-8-14 17:52

参见附件。

香川群子 · 发表于 2014-8-14 21:42

分二步完成。

程序用法指南：
一、按下统计按钮：
  立即得到各公司有效票数统计

二、按下分配按钮：
  按J6单元格中指定人数进行分配
1.自动以平均票数为目标值进行计算。
但如果某个公司总票数>平均票数，则需手工拆分后重算
2.计算完成后，可能会在按人数分配之外有剩余未分完的1列
此时只需在K2单元格中输入比P1单元格中上次分配数稍大的数
然后重新计算……反复直到正好分完。

                     Excel Home 香川群子 2014.08.14

香川群子 · 发表于 2014-8-14 21:43

代码已做了详细注释：

Sub kagawa_Count() '字典统计各公司有效发票数 (编号和客户代码相同合并算一单)
Dim ar, tr, dic, i&, s$, t$, t1$, tms#
tms = Timer
tr = [a3].CurrentRegion '记录原数据
[a3].CurrentRegion.Sort [e3], 1, [f3], , 1, , , 1 '按编号、客户代码排序
ar = [a3].CurrentRegion '读取排序后数据到数组ar
[a3].CurrentRegion = tr '恢复原数据状态
Set dic = CreateObject("Scripting.Dictionary") '定义字典
t1 = ar(1, 5) & ar(1, 6) '比较用合并编号和客户代码的初始值
For i = 2 To UBound(ar)
s = ar(i, 1) '以第1列公司名作为关键词key
t = ar(i, 5) & ar(i, 6) '合并编号和客户代码
If t <> t1 Then '如编号和客户代码不同则算一单
dic(s) = dic(s) + 1 '统计计入该公司对应字典Item项
t1 = t '更新合并编号和客户代码
End If
Next
[j4].CurrentRegion = "" '清空统计区域
[j4].Resize(dic.Count, 2) = WorksheetFunction.Transpose(Array(dic.Keys, dic.Items)) '输出字典统计结果
[j4].Resize(dic.Count, 2).Sort [j4], 1, , , , , , 2 '按公司名称排序
MsgBox Format(Timer - tms, "0.000s") '计算耗时
End Sub
Sub kagawa_Distribute()
Dim ar, br, h&, i&, j&, m&, n&, s&, t&, tms#
tms = Timer
[j4].CurrentRegion.Sort [k4], 2, , , , , , 2 '按票数倒序排序
ar = [j4].CurrentRegion '读取数据到数组ar
[j4].CurrentRegion.Sort [j4], 1, , , , , , 2 '恢复按公司名称排序状态
m = UBound(ar) '行数m即公司总数
n = [j2] '指定人数n
h = WorksheetFunction.Sum([k4].Resize(m)) '总和h
s = WorksheetFunction.Max([k4].Resize(m)) '所有公司中票数最多公司的最大值s
t = [k2]: If t = 0 Then t = h \ n + 1 '分配目标值t 可在K2单元格中指定如无指定则按平均值计算
If t < s Then MsgBox "最大票数公司 " & s & " > 分配目标值 " & t & vbCr & " 无法分配请手工调整拆分该公司!": Exit Sub
[p1] = t: [k2] = ""
ReDim br(m, n + 5)
For j = 1 To n + 5 '按人数分配
For i = 1 To m '遍历检查各个公司
If br(i, 0) = 0 Then '如该公司未被分配则
If br(0, j) + ar(i, 2) <= t Then '如果分配后不超出目标值则可以分配
br(i, 0) = ar(i, 1) '第1列记录公司名
br(i, j) = ar(i, 2) '该业务员对应j列记入
br(0, j) = br(0, j) + ar(i, 2) '在第1行统计该业务员对应j列的总计
End If
End If
Next
br(0, 0) = br(0, 0) + br(0, j) '全部已分配数进行统计
If br(0, 0) = h Then Exit For '全部分配完成后退出
Next
[m3].CurrentRegion = "" '清空输出区域
[m3].Resize(1 + m, 1 + j) = br '输出分配结果
[m3].CurrentRegion.Sort [m3], 1, , , , , , 1 '结果按公司名称排序
MsgBox Format(Timer - tms, "0.000s ") '计算耗时
End Sub

复制代码

robinzzy · 发表于 2014-8-15 09:11

香川群子发表于 2014-8-14 21:42
分二步完成。

程序用法指南：

你好，女神。真的很感谢！我试了一下，有两个小问题还想请教一下，1个就是如果我把“人数指定”改成2个人，或者4个人，分配结果都会多出一列，只显示Company01的6份。
具体结果请看附件内，不知有没有办法把它自动并进去，不要单独列呢？

另外一个小问题就是能否把2个按键合并成1个呢？按1个就可以直接显示统计结果和分配结果。

谢谢谢谢！！！

按人数均分开票_kagawa.rar (19.72 KB, 下载次数: 4)

香川群子 · 发表于 2014-8-15 10:47

robinzzy 发表于 2014-8-15 09:11
你好，女神。真的很感谢！我试了一下，有两个小问题还想请教一下，1个就是如果我把“人数指定”改成2个人 ...

按公司统计票数，这个基本上不会有问题，可以一键搞定。

但是，按人数分配时，可能不那么顺利，需要人工调整。
因此，两个按钮不能合并。

手工调整问题在这里：
【某个公司合计票数很多，已经超过平均数……】
即，如果这个公司的发票全部让一个人去做，会不会不太公平？

当然，如果数据量大、公司数较多时，应该可能不会出现这个问题。

如果你确认这个问题确实不必考虑，那么可以考虑合并按钮。

香川群子 · 发表于 2014-8-15 10:50

robinzzy 发表于 2014-8-15 09:11
你好，女神。真的很感谢！我试了一下，有两个小问题还想请教一下，1个就是如果我把“人数指定”改成2个人 ...

第2个问题，我在程序说明中已经提到：

如果一次计算有剩余，那么需要调整目标票数以后再试一次，直到符合要求。

调整方法是目标票数+1

当然，这个部分确实也可以搞成完全自动话……

香川群子 · 发表于 2014-8-15 11:04

好了，一个按钮完成统计和分配的代码修改好了。

现在的问题是，如果某个公司票数过多，多于按人均计算的平均票数，
那么最后的目标分配数会以最大票数为基准计算，出现需要的人数比指定人数少1人的结果。呵呵。

这个问题楼主你自己去思考吧。（实际工作中也许不会发生。）

香川群子 · 发表于 2014-8-15 11:19

上代码，加注释：

Sub kagawa_Count()
Dim ar, br, tr, dic, h&, i&, j&, m&, n&, r&, s$, t$, t1$, tms#
tms = Timer
tr = [a3].CurrentRegion '当前数据存入临时数组tr
[a3].CurrentRegion.Sort [e3], 1, [f3], , 1, , , 1 '当前数据按【编号、客户代码】排序
ar = [a3].CurrentRegion '排序后的数据读入数组ar
[a3].CurrentRegion = tr '从临时数组tr中恢复数据到排序前状态
'如果排序对原数据表无影响，那么只要保留中间2句代码即可。（数据量大时影响速度）
Set dic = CreateObject("Scripting.Dictionary") '设置字典dic
t1 = ar(1, 5) & ar(1, 6)
For i = 2 To UBound(ar) '遍历统计
s = ar(i, 1) '公司名
t = ar(i, 5) & ar(i, 6) '合并【编号、客户代码】
If t <> t1 Then
dic(s) = dic(s) + 1 '字典按公司分类、统计【编号、客户代码】不同的有效票数
t1 = t
End If
Next
[j4].CurrentRegion = ""
[j4].Resize(dic.Count, 2) = WorksheetFunction.Transpose(Array(dic.Keys, dic.Items))
[j4].CurrentRegion.Sort [k4], 2, , , , , , 2 '输出统计结果以后按票数倒排序
ar = [j4].CurrentRegion '取得排序后的数据读入数组ar
[j4].CurrentRegion.Sort [j4], 1, , , , , , 2 '公司票数统计部分按公司名排序显示
m = UBound(ar) '公司总数m
n = [j2] '指定人数n
h = WorksheetFunction.Sum([k4].Resize(m)) '票数总和h
r = h \ n + 1 '按人数计算平均票数作为目标值
Do '循环计算检查
ReDim br(m, n) '定义存放结果的数组br
For j = 1 To n '遍历各个人数
For i = 1 To m '遍历各个公司
If br(i, 0) = 0 Then '如该公司未被分配则检查
If br(0, j) + ar(i, 2) <= r Then '检查求和后结果不超过目标值r时可以分配
br(i, 0) = ar(i, 1): br(i, j) = ar(i, 2): br(0, j) = br(0, j) + ar(i, 2) '记录
End If
End If
Next
br(0, 0) = br(0, 0) + br(0, j) '统计已完成分配的票数
Next
If br(0, 0) = h Then Exit Do Else r = r + 1
'如已分配票数和总和h相等则结束循环，否则目标值r+1后重新计算、直到没有剩余完成所有公司的分配
Loop
[k2] = r '记录本次分配目标值
[m3].CurrentRegion = ""
[m3].Resize(1 + m, 1 + n) = br '输出分配结果
[m3].CurrentRegion.Sort [m3], 1, , , , , , 1 '按公司名排序
MsgBox Format(Timer - tms, "0.000s ") '本次程序代码计算时间
End Sub

复制代码

robinzzy · 发表于 2014-8-15 18:03

香川群子发表于 2014-8-15 11:19
上代码，加注释：

谢谢女神老师！

我还有一个问题，可否麻烦帮我改一下代码。情况是这样的：

所有的分公司会提交一张填完的excel文件（所有公司的表格模板都一致），如附件中的a文件。现在要做的是，通过一个按钮把所有分公司的Excel内容汇总在一张同样模板的combine excel file里。

我已经写了一段代码，麻烦能够帮忙改一下或者替换以实现合并的目的。

我的想法是，把所有分公司的文件保存在同一个文件夹内，然后要求各分公司把文件名统一成：张公司 - XX子公司，然后通过一段code实现只要文件名以“张公司”开头，则自动合并所有内容至一张表。

麻烦女神帮忙了，谢谢你！！！

a.rar (21.16 KB, 下载次数: 6)

		自动登录	找回密码
密码			免费注册

[求助] MACRO 自动平均分配工作