'数量不多采用暴力获取,效果还不错,而且车的数量可以不限,初始偏差值精度自己设置。可多运行几次自己找个最合适的,输出在立即窗口。
Option Explicit
Const NUM = 3 '车的数量,这里为3
Sub test()
Dim arr, i, j, t, n, sum, d, min, dd, total, ss, brr, a, s
arr = Range("a2:b" & Cells(Rows.Count, "a").End(xlUp).Row)
For a = 1 To NUM - 1
total = 0
For i = 1 To UBound(arr, 1)
total = total + arr(i, 2)
Next
d = total / (NUM - a + 1): min = total
dd = d * 0.001 '初始偏差值(0.1%)
Do
Randomize
For j = 1 To 10 ^ 5
For i = 1 To UBound(arr, 1)
n = Int(Rnd * UBound(arr, 1)) + 1
t = arr(i, 1): arr(i, 1) = arr(n, 1): arr(n, 1) = t
t = arr(i, 2): arr(i, 2) = arr(n, 2): arr(n, 2) = t
Next
sum = 0: s = vbNullString
For i = 1 To UBound(arr, 1)
sum = sum + arr(i, 2)
s = s & arr(i, 1) & ","
If Abs(sum - d) <= dd Then
If min > Abs(sum - d) Then
min = Abs(sum - d): ss = s
Exit Do
End If
End If
Next i, j
dd = dd * 1.1
Loop Until sum <> total
ss = Left(ss, Len(ss) - 1)
Debug.Print sum, ss
n = 0: brr = arr
s = Split(ss, ",")
For i = 1 To UBound(arr, 1)
For j = 0 To UBound(s)
If arr(i, 1) = s(j) Then Exit For
Next
If j = UBound(s) + 1 Then
n = n + 1
For j = 1 To UBound(arr, 2)
brr(n, j) = arr(i, j)
Next
End If
Next
ReDim arr(1 To n, 1 To UBound(arr, 2))
For i = 1 To n
For j = 1 To UBound(arr, 2)
arr(i, j) = brr(i, j)
Next j, i, a
sum = 0: ss = vbNullString
For i = 1 To UBound(arr, 1)
sum = sum + arr(i, 2)
ss = ss & arr(i, 1) & ","
Next
ss = Left(ss, Len(ss) - 1)
Debug.Print sum, ss
End Sub |