VBA code to subtract cell value from previous cell values for every line

[paneiro]

Hello, i rather new vba and i have found great a difficulty to find a solution for this problem.
I have a flat xls table with 100000+ rows and 100+ columns with blank cells, 0 value cells, >0 value cells and <0 cells . What i want to do is a vba code to run through every line and when it finds a <0 value cell to go back and start subtracting this value from the previous cells until it comes to =0 OR >0 (subtract only from the positive ones). Then continue from were it stopped (the negative value) until the end of the line. Then it has to loop for every line until the end. Blank and 0 cells are considered as 0 value.Please see below an example of a test dataset and the desired results. The "tricky" part is in Line 3 where the subtraction leads to negative result since there are no more values to subtract and in this case sets the cell value to 0.

Thank you in advance
P

L1	100	50		0	-10	100			-50
L2	0		200	-100	-50	40	-10		50
L3		300		-400		100	50		30
L4	100	100	100	100		-450	100		-50
L1_Result	100	40		0	0	50			0
L2_Result	0		50	0	0	30	0		50
L3_Result		0		0		100	50		30
L4_Result	50	0	0	0		0	50		0

<tbody>
</tbody>

 

[RickXL]

Hi and welcome to the MrExcel Message Board.

I have assumed that your L4 result of 50 is not right. That is the one in the first column. If I haver followed the logic correctly it should be 0?

Also you mention over 100,000 rows. As far as I know the best way to do that is by using arrays in VBA. So I have done that. There must be resource limitations at some point but on my Intel Q6600 with 8GB it worked OK. I tested it with 100,000 rows and 1,000 columns. I did not check each result!

You need to paste this code into a new Module and run it from there.
The sheet names can be overtyped if you are using others.
It finds the used rows and columns before it starts.
The processing is row by row and resets itself at the end of a row.
The columns are processed from right to left forming a cumulative sum of the negative values as it progresses.
These negative values are added to the positive values until another negative value is found.
I was not too clear on the logic here so please respond with some more representative test data if I have made the wrong guess.

Sub Calc()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim arrData As Variant
    Dim lr As Long
    Dim lc As Long
    Dim iRow As Long
    Dim iCol As Long
    Dim cuSum As Long
    Dim negSeq As Boolean
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")

    With ws1
        lr = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        lc = .Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
        arrData = .Range("A1").Resize(lr, lc)

        For iRow = 1 To UBound(arrData, 1)
            cuSum = 0
            For iCol = UBound(arrData, 2) To 2 Step -1
                If arrData(iRow, iCol) < 0 Then
                    cuSum = cuSum + arrData(iRow, iCol)
                    arrData(iRow, iCol) = 0
                End If
                
                If arrData(iRow, iCol) > 0 Then
                    If (arrData(iRow, iCol) + cuSum) > 0 Then
                        arrData(iRow, iCol) = arrData(iRow, iCol) + cuSum
                        cuSum = 0
                    Else
                        cuSum = cuSum - arrData(iRow, iCol)
                        arrData(iRow, iCol) = 0
                    End If
                End If
                
            Next
        Next
    End With
    
    With ws2
        .Cells.Clear
        .Range("A1").Resize(lr, lc) = arrData
    End With
    
    MsgBox "Calculation Completed"
    
End Sub

 

[paneiro]

Hi and welcome to the MrExcel Message Board.

I have assumed that your L4 result of 50 is not right. That is the one in the first column. If I haver followed the logic correctly it should be 0?

Also you mention over 100,000 rows. As far as I know the best way to do that is by using arrays in VBA. So I have done that. There must be resource limitations at some point but on my Intel Q6600 with 8GB it worked OK. I tested it with 100,000 rows and 1,000 columns. I did not check each result!

You need to paste this code into a new Module and run it from there.
The sheet names can be overtyped if you are using others.
It finds the used rows and columns before it starts.
The processing is row by row and resets itself at the end of a row.
The columns are processed from right to left forming a cumulative sum of the negative values as it progresses.
These negative values are added to the positive values until another negative value is found.
I was not too clear on the logic here so please respond with some more representative test data if I have made the wrong guess.

Sub Calc()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim arrData As Variant
    Dim lr As Long
    Dim lc As Long
    Dim iRow As Long
    Dim iCol As Long
    Dim cuSum As Long
    Dim negSeq As Boolean
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")

    With ws1
        lr = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        lc = .Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
        arrData = .Range("A1").Resize(lr, lc)

        For iRow = 1 To UBound(arrData, 1)
            cuSum = 0
            For iCol = UBound(arrData, 2) To 2 Step -1
                If arrData(iRow, iCol) < 0 Then
                    cuSum = cuSum + arrData(iRow, iCol)
                    arrData(iRow, iCol) = 0
                End If
                
                If arrData(iRow, iCol) > 0 Then
                    If (arrData(iRow, iCol) + cuSum) > 0 Then
                        arrData(iRow, iCol) = arrData(iRow, iCol) + cuSum
                        cuSum = 0
                    Else
                        cuSum = cuSum - arrData(iRow, iCol)
                        arrData(iRow, iCol) = 0
                    End If
                End If
                
            Next
        Next
    End With
    
    With ws2
        .Cells.Clear
        .Range("A1").Resize(lr, lc) = arrData
    End With
    
    MsgBox "Calculation Completed"
    
End Sub

Hello RickXL thank you very much for your reply,

you are right about the L4 mistake and i am very sorry for that. What i want the code to do is actually to go from left to right until it finds a negative value, do the calculations to the left and when it reaches to the accepted result (>=0), start going to the right again from the cell that found the negative value, until the next cell with a negative value that will turn it back to left again. (there is a case that in the second turn to left it will end further than the previous one which means that it will change the numbers of the first one). Below is a test sample the first line represent the actual data, the second line the data after running the code and the third one result that should be given.

1000	800		50		-250		-100		200		-150	100	0	0	0	0		-200		100	100	200
1000	0		0		0		0		0		0	0	0	0	0	0		0		100	100	200
1000	450		0		0		0		0		0	0	0	0	0	0		0		100	100	200

<tbody>
</tbody>

Again thank you very much for helping me.
P

 

[RickXL]

Hi,

I think there was only a sign wrong.

However, I notice that your new data has 1000 in column 1 and not L1 etc. I assumed that the real data included labels in column 1.
If that is not the case and data starts in column 1 then the red 2 in the code below will need to be changed into a 1.

Please try this:

Sub Calc()

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim arrData As Variant
    Dim lr As Long
    Dim lc As Long
    Dim iRow As Long
    Dim iCol As Long
    Dim cuSum As Long
    Dim negSeq As Boolean
    
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")

    With ws1
        lr = .Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
        lc = .Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
        arrData = .Range("A1").Resize(lr, lc)

        For iRow = 1 To UBound(arrData, 1)
            cuSum = 0
            For iCol = UBound(arrData, 2) To 2 Step -1
                If arrData(iRow, iCol) < 0 Then
                    cuSum = cuSum + arrData(iRow, iCol)
                    arrData(iRow, iCol) = 0
                End If
                
                If arrData(iRow, iCol) > 0 Then
                    If (arrData(iRow, iCol) + cuSum) > 0 Then
                        arrData(iRow, iCol) = arrData(iRow, iCol) + cuSum
                        cuSum = 0
                    Else
                        cuSum = cuSum + arrData(iRow, iCol)
                        arrData(iRow, iCol) = 0
                    End If
                End If
                Debug.Print cuSum
                .Cells(iRow + 1, iCol) = arrData(iRow, iCol)
            Next
        Next
    End With
    
    With ws2
        .Cells.Clear
        .Range("A1").Resize(lr, lc) = arrData
    End With
    
    MsgBox "Calculation Completed"
    
End Sub

 

[paneiro]

And it works perfectly. Thank you very much for this RickXL

 

[RickXL]

And it works perfectly.

Great to hear and thanks for letting me know.

Regards,

 

[abdul7019]

Hello

What if I want to subtract with specific Coloums

Thanks
Abdul Raheem