'局部最优全局不一定最优,但接近于全局最优应该不会有问题,,,
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 |