Алгоритм равномерного распределения чисел подскажите

Option Explicit

Private Function IncBin(ByRef V() As Byte) As Boolean
Dim i As Long, j As Long
For i = 0 To UBound(V)
    If V(i) = 0 Then
        V(i) = 1
        For j = 0 To i - 1
            V(j) = 0
        Next j
    IncBin = True
    Exit Function
    End If
    IncBin = False
Next i
End Function

Private Sub VSum(ByRef A() As Double, ByRef V() As Byte, ByRef FirstSum As Double, ByRef SecondSum As Double)
Dim i As Long
FirstSum = 0
SecondSum = 0
For i = 0 To UBound(A)
    If V(i) = 1 Then
        FirstSum = FirstSum + A(i)
    Else
        SecondSum = SecondSum + A(i)
    End If
Next i
End Sub

Private Sub Split(ByRef A() As Double, ByRef V() As Byte, ByRef B() As Double, ByRef C() As Double)
Dim i As Long
Dim nB As Long, nC As Long
ReDim B(0 To UBound(A))
ReDim C(0 To UBound(A))

For i = 0 To UBound(A)
    If V(i) = 1 Then
        B(nB) = A(i)
        nB = nB + 1
    Else
        C(nC) = A(i)
        nC = nC + 1
    End If
Next i
ReDim Preserve B(0 To nB - 1)
ReDim Preserve C(0 To nC - 1)
End Sub

Private Sub OptV(ByRef A() As Double, ByRef B() As Double, ByRef C() As Double)
Dim V() As Byte
Dim minV() As Byte

Dim FirstSum As Double, SecondSum As Double
Dim minS As Double, S As Double
Dim i As Long
ReDim V(0 To UBound(A)) As Byte
ReDim minV(0 To UBound(A)) As Byte
'minS = 1000
For i = 0 To UBound(A)
    minS = minS + Abs(A(i))
Next i
While IncBin(V)
    Call VSum(A, V, FirstSum, SecondSum)
    S = Abs(FirstSum - SecondSum)
    If S < minS Then
        minS = S
        minV = V
    End If
Wend
Call Split(A, minV, B, C)
End Sub

'Задача: разбить массив действительных чисел A на два массива B и С таких,
'что S = abs(Sum(B[i])-Sum(C[j])) -> min
'Решение простым перебором всех вариантов,ни какой оптимизации
'В случае, если есть несколько вариантов решения, для которых S = 0,
'то будет выведен только первый
Public Sub MainSub()
Dim B() As Double, bSum As Double
Dim C() As Double, cSum As Double
Dim i As Long
Dim t As Date

'Число элементов массива (При N>20 компьютер может на долго задуматься)
Const N = 19
'Создание массива
Randomize
Dim A(0 To N - 1) As Double
For i = 0 To N - 1
    A(i) = Rnd * 10
Next i
'Поиск решения
t = Time
Call OptV(A, B, C)
t = Time - t
'Вывод результатов
Debug.Print "First array:"
For i = 0 To UBound(B)
    bSum = bSum + B(i)
    Debug.Print B(i)
Next i
Debug.Print "Sum = " & bSum

Debug.Print ""
Debug.Print "Second array:"
For i = 0 To UBound(C)
    cSum = cSum + C(i)
    Debug.Print C(i)
Next i
Debug.Print "Sum = "; cSum
Debug.Print "Delta = " & Abs(bSum - cSum)
Debug.Print "Array size = " & N
Debug.Print "Time = " & t
'Время работы:
'PIV 1500 MHz
'Array size = 20
'Time = 0:00:08
'Увеличение N на 1 увеличивает время работы в 2 раза :(
End Sub