vba均衡分组 均衡分班【根据平均值进行分组】

zz1008080

厂里经营扩张，找个几个老师傅。老是因为分配量不均衡问题困扰。想要实现的结果根据平均值进行分组，每个师傅的到的量尽可能差距要小。求各位大神帮帮忙。

renkangjizhen

头尾取数法：第一最大值配第一最小值，第二最大值配第二最小值······

一把小刀闯天下

'局部最优全局不一定最优，但接近于全局最优应该不会有问题，，，

Option Explicit

Const NUM = 4 '操作员数量

Sub test()
  Dim arr, brr, i, j, k, n, sum, min, cnt, s, t
  arr = Range("k18:m" & [k18].End(xlDown).Row).Value
  For i = 1 To UBound(arr, 1)
    sum = sum + arr(i, 1)
    arr(i, 2) = vbNullString
    arr(i, 3) = i
  Next
  sum = Int(sum / NUM)
  brr = arr
  For i = 1 To NUM - 1
    cnt = 0
    For j = 1 To UBound(brr, 1)
      If Len(brr(j, 2)) = 0 Then
        cnt = cnt + 1
        For k = 1 To 3
          arr(cnt, k) = brr(j, k)
        Next
      End If
    Next
    min = sum: s = vbNullString
    ReDim crr(1 To 2 ^ cnt, 1 To 2)
    crr(2, 1) = arr(1, 1): crr(2, 2) = 1
    n = 2
    For j = 2 To cnt
      For k = n + 1 To 2 * n
        crr(k, 1) = crr(k - n, 1) + arr(j, 1)
        crr(k, 2) = crr(k - n, 2) & Space(1) & arr(j, 3)
        If Abs(sum - crr(k, 1)) < min Then
          min = Abs(sum - crr(k, 1))
          s = crr(k, 2)
        End If
      Next
      n = n * 2
    Next
    t = Split(Trim(s))
    For j = 0 To UBound(t)
      brr(t(j), 2) = i
    Next
  Next
  ReDim arr(1 To 2, 1 To NUM + 2)
  For i = 1 To UBound(brr, 1)
    If Len(brr(i, 2)) Then n = brr(i, 2) Else n = NUM: brr(i, 2) = n
    arr(1, n) = "a" & n & "量"
    arr(2, n) = arr(2, n) + brr(i, 1)
  Next
  [k18].Resize(UBound(brr, 1), 2) = brr
  [n17].Resize(2, UBound(arr, 2)) = arr
End Sub

yjh_27

参见附件。

zz1008080

yjh_27 发表于 2020-12-26 16:14
参见附件。

谢谢大佬的帮助

zz1008080

一把小刀闯天下 发表于 2020-12-26 16:04
'局部最优全局不一定最优，但接近于全局最优应该不会有问题，，，

Option Explicit

谢谢大佬的帮助

astupig

用规划求解/Solver来实现也是非常方便的。 见附件。

yjh_27

同类
根据工作人员和任务总数，合理分配任务量
http://club.excelhome.net/thread-1569992-1-1.html
(出处: ExcelHome技术论坛)

hnyeke

yjh_27 发表于 2020-12-26 16:14
参见附件。

https://club.excelhome.net/threa ... tml?_dsign=f0eac2af
请看下这个贴子。