Dim Choices As Variant
Sub test()
Dim arrInput As Variant, workArray As Variant
Dim targetVal As Double
Dim currentVal As Double, currentResult As Variant, workVal As Double
Dim arrResult1() As Double, arrResult2() As Double
Dim i As Long, Size As Long, Point1 As Long, Point2 As Long
arrInput = Application.Transpose(Range("A1:A12").Value)
targetVal = WorksheetFunction.Sum(arrInput) / 2
currentVal = 9E+99
Size = UBound(arrInput)
ReDim Choices(1 To Size)
For i = 1 To Size
Choices(i) = (i <= Size / 2)
Next i
Do
workVal = 0
For i = 1 To Size
If Choices(i) Then
workVal = workVal + arrInput(i)
End If
Next i
If Abs(workVal - targetVal) < currentVal Then
currentVal = Abs(workVal - targetVal)
currentResult = Choices
End If
DoEvents
Loop Until NextChoice
ReDim arrResult1(1 To Size / 2): Point1 = 0
ReDim arrResult2(1 To Size / 2): Point2 = 0
For i = 1 To Size
If currentResult(i) Then
Point1 = Point1 + 1
arrResult1(Point1) = arrInput(i)
Else
Point2 = Point2 + 1
arrResult2(Point2) = arrInput(i)
End If
Next i
Range("B1:B6").Value = Application.Transpose(arrResult1)
Range("C1:C6").Value = Application.Transpose(arrResult2)
End Sub
Function NextChoice(Optional ByRef OverFlow As Boolean) As Boolean
Dim lookAt As Long, WriteTo As Long
Dim arrResult As Variant
arrResult = Choices
lookAt = 1
Do Until arrResult(lookAt)
lookAt = lookAt + 1
Loop
Do
If arrResult(lookAt) Then
WriteTo = WriteTo + 1
arrResult(lookAt) = False
arrResult(WriteTo) = True
lookAt = lookAt + 1
Else
Rem done
arrResult(WriteTo) = False
arrResult(lookAt) = True
Exit Do
End If
Loop Until UBound(arrResult) < lookAt
OverFlow = (UBound(arrResult) <= lookAt)
Choices = arrResult
NextChoice = OverFlow
End Function
