Calculate sum and rearrange rows to get value

[Cimpcrro]

I have a table with positive and negative values in the same column and I need to order them so their sum at each row is closest to 0 and I need to do this based on article number.
For example, for article X I have the next order:

Book2
	C	D
1	Item no.	Value
2	111	100
3	111	200
4	111	-50
5	111	-70
6	111	-30
7	111	-40
8	111	-50
9	111	-80
10	111	-100
Sheet1

I need to rearrange it like this:

Book2
	C	D
12	Item no.	Value
13	111	100
14	111	-50
15	111	-70
16	111	200
17	111	-30
18	111	-40
19	111	-50
20	111	-80
21	111	-100
Sheet1

Thank you!

 

[Cimpcrro]

Hmmm... If that is the case, the example you posted does NOT follow the logic you explained.

In your expected output, you show 200 in the 4th spot. If we add the Running Total column to the right of this, we can see the values:
View attachment 51645

However, if we use the -30 there instead of 200, look what our Running Total is:
View attachment 51646

-50 is a lot closer to 0 than 180 is!

So, is there a mistake in the example you posted, or a mistake in the logic you posted/explained?

We need to completely and clearly understand the logic of how this is supposed to work if we want to try to come up with a solution.

You are correct, but keep in mind please that this is a simulation of Stock level. I ca still deliver 50 pcs from the next PO, then I need to stop until the next goods receipt.

 

[Joe4]

You are correct, but keep in mind please that this is a simulation of Stock level. I ca still deliver 50 pcs from the next PO, then I need to stop until the next goods receipt.

So what exactly does that mean?
I am looking for clarification so I know what I am trying to program.
Are you saying that if the running total is negative, it should ALWAYS pick up the next positive value?

And if the running total is positive, it should ALWAYS pick the next negative value?

 

[Cimpcrro]

So what exactly does that mean?
I am looking for clarification so I know what I am trying to program.
Are you saying that if the running total is negative, it should ALWAYS pick up the next positive value?

And if the running total is positive, it should ALWAYS pick the next negative value?

Exactly.
If the running total is 0 or negative, the it should ALWAYS pick up the next positive value and if the running total is positive, it should ALWAYS pick the next negative value.
If there is no more positive value to pick-up, the list shoul go on with the remaining negative values.

 

[Cimpcrro]

I have tried myself to code a few lines, but I'm far from the solution. I have used a helper column (PO values for positives and SO for negatives)
Since I'm a newbie, please excuse the mess:

Sub Macro2()

Dim NextRow As Long
NextRow = Range("A" & Rows.Count).End(xlUp).Row

Range("L" & NextRow & ":L" & NextRow).Formula = "=SUM(G1:G" & NextRow & ")"
For a = 1 To Worksheets("Destination").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Worksheets("Source Data").Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets("Source Data").Cells(i, 1).Value = "PO" Then
If Worksheets("Destination").Cells(a, 12).Value <= 0 Then
Worksheets("Source Data").Rows(i).Copy
Worksheets("Destination").Activate
b = Worksheets("Destination").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Destination").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Source Data").Rows(i).Delete Shift:=xlUp

NextRow = Range("A" & Rows.Count).End(xlUp).Row

Range("L" & NextRow & ":L" & NextRow).Formula = "=SUM(G1:G" & NextRow & ")"




End If
End If
'End If
Next
Next


NextRow = Range("A" & Rows.Count).End(xlUp).Row

Range("L" & NextRow & ":L" & NextRow).Formula = "=SUM(G1:G" & NextRow & ")"

For a = 1 To Worksheets("Destination").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Worksheets("Source Data").Cells(Rows.Count, 1).End(xlUp).Row
If Worksheets("Source Data").Cells(i, 1).Value = "SO" Then
If Worksheets("Destination").Cells(a, 12).Value > 0 Then
Worksheets("Source Data").Rows(i).Copy
Worksheets("Destination").Activate
b = Worksheets("Destination").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Destination").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Source Data").Rows(i).Delete Shift:=xlUp

NextRow = Range("A" & Rows.Count).End(xlUp).Row

Range("L" & NextRow & ":L" & NextRow).Formula = "=SUM(G1:G" & NextRow & ")"




End If
End If
Next
Next

Application.CutCopyMode = False
Worksheets("Source Data").Activate
Worksheets("Source Data").Cells(1, 1).Select
MsgBox ("Sortare finalizata")
End Sub

 

[Joe4]

I have some ideas, but it will be a little while before I get the chance to tackle it.
But I see in the code that you posted, you are referencing multiple worksheets.
Are you not editing the original range?
Do you want the adjusted results on a different page?

 

[Cimpcrro]

I have some ideas, but it will be a little while before I get the chance to tackle it.
But I see in the code that you posted, you are referencing multiple worksheets.
Are you not editing the original range?
Do you want the adjusted results on a different page?

Any solution is welcome. I just need the result to have the discussed logic applied.

 

[Joe4]

Can you please answer the question though?
Do you want the original range rearranged (so you are only left with one range), or do you want the results in a separate list elsewhere (so you are left with two ranges)?

 

[Cimpcrro]

Can you please answer the question though?
Do you want the original range rearranged (so you are only left with one range), or do you want the results in a separate list elsewhere (so you are left with two ranges)?

I think copying in a new tab is the better soluition, this way the results could be checked against sourse data

 

[Joe4]

Ok assuming that your data is Sheet1, in columns C and D starting on row 1, and you have a blank Sheet2, try this code:

Sub MyRearrangeMacro()

    Dim lr As Long
    Dim r As Long
    Dim curr
    Dim prev
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim tot As Double
    Dim i As Long
    
    Application.ScreenUpdating = False
    
'   Copy data from Sheet1 to Sheet2
    Sheets("Sheet1").Activate
    Cells.Copy
    Sheets("Sheet2").Activate
    Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    
'   Find last row in column C with data
    lr = Cells(Rows.Count, "C").End(xlUp).Row
    
'   Loop through all rows starting at row 2
    For r = 2 To lr
'       Get current item
        curr = Cells(r, "C")
'       Only check if previous item same as current item
        If curr = prev Then
'           Set range value
            Set rng1 = Range("C" & r - 1) 'item value
            Set rng2 = Range("C2:C" & r - 1) 'column C range
            Set rng3 = Range("D2:D" & r - 1) 'column D range
'           Calculate current running total up to current row
            tot = Application.WorksheetFunction.SumIf(rng2, rng1, rng3)
'           If tot >0, and current value > 0 grab the next negative value
            If tot > 0 And Cells(r, "D") > 0 Then
'               Loop through rows below looking for negative value
                For i = r + 1 To lr
'                   See if value is negative
                    If Cells(i, "D") < 0 Then
'                       See if item number is the same
                        If Cells(i, "C") = curr Then
'                           Cut and paste row
                            Rows(i).Cut
                            Rows(r).Insert Shift:=xlDown
                        End If
'                       Exit the for loop
                        Exit For
                    End If
                Next i
            Else
'               If tot < 0 and current value < 0 grabe the next positive value
                If tot < 0 And Cells(r, "D") < 0 Then
'                   Loop through rows below looking for positive value
                    For i = r + 1 To lr
'                       See if value is positive
                        If Cells(i, "D") > 0 Then
'                           See if item number is the same
                            If Cells(i, "C") = curr Then
'                               Cut and paste row
                                Rows(i).Cut
                                Rows(r).Insert Shift:=xlDown
                            End If
'                           Exit the for loop
                            Exit For
                        End If
                    Next i
                End If
            End If
        End If
'       Set previous item equal to current one
        prev = curr
    
    Next r
    
    Application.ScreenUpdating = True
    
    MsgBox "Macro complete!"
    
End Sub

Like I said, it is pretty "brute force" method, but it seems to do what you want. It works on the examples you posted and we discussed.

 

[Cimpcrro]

Ok assuming that your data is Sheet1, in columns C and D starting on row 1, and you have a blank Sheet2, try this code:

Sub MyRearrangeMacro()

    Dim lr As Long
    Dim r As Long
    Dim curr
    Dim prev
    Dim rng1 As Range
    Dim rng2 As Range
    Dim rng3 As Range
    Dim tot As Double
    Dim i As Long
   
    Application.ScreenUpdating = False
   
'   Copy data from Sheet1 to Sheet2
    Sheets("Sheet1").Activate
    Cells.Copy
    Sheets("Sheet2").Activate
    Range("A1").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
   
'   Find last row in column C with data
    lr = Cells(Rows.Count, "C").End(xlUp).Row
   
'   Loop through all rows starting at row 2
    For r = 2 To lr
'       Get current item
        curr = Cells(r, "C")
'       Only check if previous item same as current item
        If curr = prev Then
'           Set range value
            Set rng1 = Range("C" & r - 1) 'item value
            Set rng2 = Range("C2:C" & r - 1) 'column C range
            Set rng3 = Range("D2:D" & r - 1) 'column D range
'           Calculate current running total up to current row
            tot = Application.WorksheetFunction.SumIf(rng2, rng1, rng3)
'           If tot >0, and current value > 0 grab the next negative value
            If tot > 0 And Cells(r, "D") > 0 Then
'               Loop through rows below looking for negative value
                For i = r + 1 To lr
'                   See if value is negative
                    If Cells(i, "D") < 0 Then
'                       See if item number is the same
                        If Cells(i, "C") = curr Then
'                           Cut and paste row
                            Rows(i).Cut
                            Rows(r).Insert Shift:=xlDown
                        End If
'                       Exit the for loop
                        Exit For
                    End If
                Next i
            Else
'               If tot < 0 and current value < 0 grabe the next positive value
                If tot < 0 And Cells(r, "D") < 0 Then
'                   Loop through rows below looking for positive value
                    For i = r + 1 To lr
'                       See if value is positive
                        If Cells(i, "D") > 0 Then
'                           See if item number is the same
                            If Cells(i, "C") = curr Then
'                               Cut and paste row
                                Rows(i).Cut
                                Rows(r).Insert Shift:=xlDown
                            End If
'                           Exit the for loop
                            Exit For
                        End If
                    Next i
                End If
            End If
        End If
'       Set previous item equal to current one
        prev = curr
   
    Next r
   
    Application.ScreenUpdating = True
   
    MsgBox "Macro complete!"
   
End Sub

Like I said, it is pretty "brute force" method, but it seems to do what you want. It works on the examples you posted and we discussed.

This is great! From what I tested so far it works perfect!
Thank you very much for your help!