Split range based on total

[amrane]

Dear forum,

I am looking for your support regarding the below problem,

I am working manually to split the table to two equivalent portion as much as possible,
so far, I tried to built some formula, but I failed,
can you advise me any idea how to split automatically ?

thanks in advance for your help,
Br,
Amrane

[大灰狼1976]

Hi amrane!
something like this:

Private Sub CommandButton1_Click()
Dim arr, i&, j&, arr1, sm1#, sm2#, tmp#, tmp1#, r&, i1&, j1&, b As Boolean, n&
arr = Range("c3:c" & [c65536].End(3).Row)
[e1].CurrentRegion.Offset(2).ClearContents
n = UBound(arr) Mod 2
ReDim arr1(1 To -Int(-UBound(arr) / 2), 1 To 2)
For i = 1 To UBound(arr) Step 2
r = r + 1
arr1(r, 1) = arr(i, 1): sm1 = sm1 + arr1(r, 1)
If i < UBound(arr) Then
arr1(r, 2) = arr(i + 1, 1): sm2 = sm2 + arr1(r, 2)
End If
Next i
Retry:
b = False
tmp = Format(sm1 - sm2, "0.0")
tmp1 = tmp / 2
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr1) - n
If Abs(arr1(i, 1) - arr1(j, 2) - tmp / 2) < Abs(tmp1) Then
tmp1 = arr1(i, 1) - arr1(j, 2) - tmp / 2
i1 = i
j1 = j
b = True
End If
Next j
Next i
If b = True Then
sm1 = sm1 - arr1(i1, 1) + arr1(j1, 2)
sm2 = sm2 - arr1(j1, 2) + arr1(i1, 1)
tmp = arr1(i1, 1)
arr1(i1, 1) = arr1(j1, 2)
arr1(j1, 2) = tmp
GoTo Retry
End If
[e3].Resize(UBound(arr1), 2) = arr1
End Sub

[amrane]

Dear Mr 1976

Many Thanks,

your version is quick & perfect,

I treid to modify little bit to show the Input number, But it looks blocking
, I don't know why!
can you please help,

Br
Amrane,

[Paul_Hossler]

Not sure I understood it all, but try this version




Option Explicit


Sub SplitList()
Dim r As Range
Dim ary As Variant, ary1() As Double, ary2() As Double
Dim i As Long, j As Long
Dim Hold As Double

'get data
Set r = Range(ActiveSheet.Range("C3"), ActiveSheet.Range("C3").End(xlDown))

'put in array
ary = Application.WorksheetFunction.Transpose(r)

'create 2 output arrays
If UBound(ary) Mod 2 = 0 Then ' even
ReDim ary1(1 To UBound(ary) \ 2)
ReDim ary2(1 To UBound(ary) \ 2)
Else
ReDim ary1(1 To UBound(ary) \ 2 + 1)
ReDim ary2(1 To UBound(ary) \ 2 + 1)
End If


'sort input descending
For i = LBound(ary) To UBound(ary) - 1
For j = i + 1 To UBound(ary)
If ary(i) < ary(j) Then
Hold = ary(i)
ary(i) = ary(j)
ary(j) = Hold
End If
Next j
Next i
'move to output arrays
j = 1
For i = LBound(ary) To UBound(ary) Step 2
ary1(j) = ary(i)
ary2(j) = ary(i + 1)
j = j + 1
Next I

'put on worksheet
Range("F3").Resize(UBound(ary1), 1).Value = Application.WorksheetFunction.Transpose(ary1)
Range("H3").Resize(UBound(ary2), 1).Value = Application.WorksheetFunction.Transpose(ary2)
End Sub

[大灰狼1976]

It's a stopgap measure. I'll revise it when I have time.



Private Sub spliter()
Dim arr, i&, j&, arr1, sm1#, sm2#, tmp#, tmp1#, r&, i1&, j1&, b As Boolean, n&


arr = Range("c3:c" & [c65536].End(3).Row)
[f3].CurrentRegion.Offset(2).ClearContents


n = UBound(arr) Mod 2
ReDim arr1(1 To -Int(-UBound(arr) / 2), 1 To 2)
For i = 1 To UBound(arr) Step 2
r = r + 1
arr1(r, 1) = arr(i, 1): sm1 = sm1 + arr1(r, 1)
If i < UBound(arr) Then
arr1(r, 2) = arr(i + 1, 1): sm2 = sm2 + arr1(r, 2)
End If
Next i
Retry:
b = False
tmp = Format(sm1 - sm2, "0.0")
tmp1 = tmp / 2
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr1) - n
If Abs(arr1(i, 1) - arr1(j, 2) - tmp / 2) < Abs(tmp1) Then
tmp1 = arr1(i, 1) - arr1(j, 2) - tmp / 2
i1 = i
j1 = j
b = True
End If
Next j
Next i
If b = True Then
sm1 = sm1 - arr1(i1, 1) + arr1(j1, 2)
If Format(sm1, "0.0") = Format(sm2, "0.0") Then GoTo 1
sm2 = sm2 - arr1(j1, 2) + arr1(i1, 1)
tmp = arr1(i1, 1)
arr1(i1, 1) = arr1(j1, 2)
arr1(j1, 2) = tmp
GoTo Retry
End If
1
'[e3].Resize(UBound(arr1), 2) = arr1


For i = 1 To UBound(arr1)
Cells(2 + i, 6) = arr1(i, 1)


Cells(2 + i, 8) = arr1(i, 2)
Next i


Range("E2").Select
Range("E2").Copy


Range("E3:E" & UBound(arr1) + 2).PasteSpecial Paste:=xlPasteFormulas
Range("G2").Select
Range("G2").Copy


Range("G3:G" & UBound(arr1) + 2).PasteSpecial Paste:=xlPasteFormulas


Range("A1").Select
Application.CutCopyMode = False


End Sub