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

paneiro

New Member
Joined
May 30, 2015
Messages
3
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

L1100500-10100-50
L20200-100-5040-1050
L3300-4001005030
L4100100100100-450100-50
L1_Result1004000500
L2_Result0500030050
L3_Result001005030
L4_Result500000500

<tbody>
</tbody>
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

RickXL

MrExcel MVP
Joined
Sep 9, 2013
Messages
4,328
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.

Code:
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

New Member
Joined
May 30, 2015
Messages
3
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.

Code:
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

MrExcel MVP
Joined
Sep 9, 2013
Messages
4,328
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:

Rich (BB code):
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
 

Watch MrExcel Video

Forum statistics

Threads
1,130,119
Messages
5,640,218
Members
417,131
Latest member
Seanr19871

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top