Option Explicit
Sub abc()
Dim a, i, j, x, y, k, n, t, p, sum, max
a = Range("b2:j" & [b2].End(xlDown).Row).Value
x = [m2].Value: y = [m3].Value
ReDim b(1 To UBound(a), 1 To 40), c(1 To UBound(a, 2), 1 To 2)
For i = 2 To UBound(a)
For j = 1 To UBound(a, 2)
c(j, 1) = a(i, j)
c(j, 2) = a(1, j)
Next
t = Array(x, x + y, x - y)
For j = 0 To 2 '标准值、正偏差、负偏差(数量降序优先处理)
Call bsort(c, 1, UBound(c), 1, 2, 1)
Call fc(c, t(j), b, i, n)
Next
Do
Call bsort(c, 1, UBound(c), 1, 2, 1)
If c(1, 1) = 0 Then Exit Do
sum = 0
For j = 1 To UBound(c)
sum = sum + c(j, 1)
If c(j, 1) = 0 Then
If sum <= x Then '余下的可以装在1个箱内
n = n + 1
For k = 1 To j - 1
b(i, n) = b(i, n) & "," & c(k, 2) & "\" & c(k, 1)
Next
b(i, n) = Mid(b(i, n), 2)
Exit Do
End If
p = j - 1: Exit For
End If
Next
If p <= 1 Then '单个或无数据
If p = 1 Then
For j = 1 To c(1, 1) \ x
n = n + 1: b(i, n) = c(1, 2) & "\" & c(1, 1)
Next
n = n + 1: b(i, n) = c(1, 2) & "\" & (c(1, 1) Mod x)
End If
Exit Do
End If
sum = c(1, 1): t = vbNullString
For j = p To 2 Step -1
sum = sum + c(j, 1): t = t & "," & j
If sum >= x + y Then '最后按正偏差装箱
t = Split(t, ",")
n = n + 1: b(i, n) = c(1, 2) & "\" & c(1, 1)
For k = 1 To UBound(t)
If k < UBound(t) Then
b(i, n) = b(i, n) & "," & c(t(k), 2) & "\" & c(t(k), 1)
c(t(k), 1) = 0
Else
b(i, n) = b(i, n) & "," & c(t(k), 2) & "\" & (c(t(k), 1) - sum Mod (x + y))
c(t(k), 1) = sum Mod (x + y)
End If
Next
c(1, 1) = 0
Exit For
End If
Next
Loop
If n > max Then max = n
n = 0
Next
For i = 1 To max: b(1, i) = Format(i, "第0箱"): Next
[n2].Resize(UBound(b), UBound(b, 2)) = b
End Sub
Function fc(a, m, b, p, n)
Dim i, j
For i = 1 To UBound(a)
If a(i, 1) = 0 Then Exit For
If a(i, 1) Mod m = 0 Then
For j = 1 To a(i, 1) \ m
n = n + 1: b(p, n) = a(i, 2) & "\" & m
Next
a(i, 1) = 0
End If
Next
End Function
Function bsort(a, first, last, left, right, key)
Dim i, j, k, t
For i = first To last - 1
For j = first To last + first - 1 - i
If a(j, key) < a(j + 1, key) Then
For k = left To right
t = a(j, k): a(j, k) = a(j + 1, k): a(j + 1, k) = t
Next
End If
Next
Next
End Function