VBA: Sum all correlating values from a table together to Cell

[NessPJ]

Hello,

I have a sheet with data obtained from somewhere else using VBA.
I would like to make VBA code to sum, some of these results together if the user has configured which cells relate to each other. For example:

Excel Row Number	Data	Relationship to Row	End Result
10	5		18
11	41		41
12	7		7
13	99		99
14	2	10	2
15	23		23
16	11	10	11
17	56		56
18	20		20

<tbody>
</tbody>

In the example the table has been configured to make Row 14 and Row 16 have a relationship with Row 10 meaning the Data from Rows 10, 14 and 16 is summed together.

Is it possible to do this?
A limitation would be that a Row can only have a single relationship defined (but thats okay).
Inside the entire table, multiple different relationships should be possible though (some could have only 2 rows defined, while others could for example have 8).

I tried to think of a way how to do this, but i get stuck because i think i need to make a new variable in VBA which is automatically created each time a relationship is found, to sum them all up afterwards?
I didn't know how to proceed there with that.

 

[Martvg]

Hi Nessjp,

Could you test this code for me?

Sub Smt()

    Dim x As Integer
    Dim y As Integer
    Dim LastRow As Integer
    Dim Smt As Integer
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For x = 2 To LastRow
    
    Smt = Cells(x, 1).Value
    
        For y = 1 To LastRow
        
        If Cells(y, 2) = x Then
        
        Smt = Smt + Cells(y, 1).Value
        
        End If
        
        Next y
    
    Cells(x, 3).Value = Smt
    
    Next x

End Sub

Hope if fulfills your needs,

Best Regards,
Mart

 

[NessPJ]

Hello Mart,

Thanks for your help so far.
The columns in my sheet are M, N, O so i changed your code respectively so columns 13, 14 and 15 were used.
I seem to run into an Overflow error now, i'm not exactly sure why that happens.
I have uploaded a stripped version of the file here, if you'd like to take a look:
Zippyshare.com - mrexceltest.xlsm

 

[Martvg]

Did a tiny bit of testing, it now ignores all cells that are not numeric in column M and thus leaves the corresponding cells in O empty.thi

Sub Test()    
    Dim x As Integer
    Dim y As Integer
    Dim LastRow As Integer
    Dim Smt As Double
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For x = 16 To LastRow
        If IsNumeric(Cells(x, 13)) Then
        Smt = Cells(x, 13).Value
        Else
        GoTo EndLine
        End If
    
    For y = 16 To LastRow
        
        If Cells(y, 14) = x Then
        
        Smt = Smt + Cells(y, 13).Value
        
        End If
        
    Next y
    
    Cells(x, 15).Value = Smt
    
EndLine:
    
    Next x


End Sub

Hope it fits your needs!

Best regards.

 

[NessPJ]

This works beautifully, thanks a lot!

So this actually works because you have a For inside a For? Can you explain why a double is needed instead of an Integer?

 

[Martvg]

A double is more accurate than an Integer, your cells in column M showed up with a comma (e.g. 3,137), this caused me to think that the number actually equaled a number with decimals (later I found out it didn't, but changing it back to Integer will not really have any extra value, therefore I left it as double).


Well, the first For is used to loop through column M, the second For is used to loop through column N.
As the second For is inside the first For, the second loop is completed for each cell in column M:
The first For starts in M16, the second For is called, it loops through all cells in column N looking for value x (the rownumber of M16), once looped through all cells in column N the second loop ends.
The first For starts again (via next x), but moves to the next cell in column M, thus M17, the second loop is called again to loop through column N to find the rownumber of M17.
This happens until the last cell in column M is reached.

Feel free to ask for any extra explanation.

Glad it works .

 

[NessPJ]

Thanks for the explanation.

The routine seems to chuckle if a Cell is found with a #REF! value.
I tried to execute the following code proceeding yours, but that seemed to run into the same problem:

LastRow = Cells(Rows.Count, "A").End(xlUp).Row


    For x = 16 To LastRow
    
        For y = 16 To LastRow
        
        If Cells(y, 13).Value = "#REF!" Then
        
        Cells(y, 13).Value = "#REFERR"
        
        End If
        
    Next y


 Next x
 
 x = 0
 
 y = 0

Firstly i tried using just your routine and added an If statement for excluding the cell if the result was an error (If ISError()), but that did not seem to work either.
Any suggestion how to fix this?

 

[Martvg]

Does this help you at all?

Sub Test()    Dim x As Integer
    Dim y As Integer
    Dim LastRow As Integer
    Dim Smt As Double
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For x = 16 To LastRow
        If IsNumeric(Cells(x, 13)) Then
        Smt = Cells(x, 13).Value
        Else
        GoTo EndLine
        End If
    
    For y = 16 To LastRow
                
        If IsNumeric(Cells(y, 14)) Then
        
            If Cells(y, 14) = x Then
            Smt = Smt + Cells(y, 13).Value
            End If
        
        End If
        
    Next y
    
    Cells(x, 15).Value = Smt
    
EndLine:
    
    Next x


End Sub

Checking if the value in Column N is numeric too.

 

[NessPJ]

Oh...it must have been late for me yesterday.... the evaluation was supposed to run in Column M (so x, not y).

I tried this, but that still gives me a Type Mismatch:

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For x = 16 To LastRow
    
        If IsNumeric(Cells(x, 13)) Then
        Smt = Cells(x, 13).Value
        ElseIf IsError(Cells(x, 13)) Then
        GoTo EndLine
        ElseIf Cells(x, 13) = CVErr(xlErrRef) Then
        GoTo EndLine
        Else
        GoTo EndLine
        End If
    
    For y = 16 To LastRow
        
        If Cells(y, 14) = x Then
        
        Smt = Smt + Cells(y, 13).Value
        
        End If
        
    Next y
    
    Cells(x, 15).Value = Smt
    
EndLine:
    
    Next x

 

[NessPJ]

I even tried adding an error check for each scenario now (probably way to rigorous), but it still won't work and pass the entire evaluation.

Dim errval As Variant          'Also tried As Error

LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For x = 16 To LastRow
    
    If IsError(Cells(x, 13).Value) Then
    errval = Cells(x, 13)
    Select Case errval
        Case CVErr(xlErrDiv0)
            GoTo EndLine
        Case CVErr(xlErrNA)
            GoTo EndLine
        Case CVErr(xlErrName)
            GoTo EndLine
        Case CVErr(xlErrNull)
            GoTo EndLine
        Case CVErr(xlErrNum)
            GoTo EndLine
        Case CVErr(xlErrRef)
            GoTo EndLine
        Case CVErr(xlErrValue)
            GoTo EndLine
        Case Else
            MsgBox "Fatale fout tijdens verwerken van de opgehaalde gegevens.", vbCritical, "Fatale fout"
    End Select
    End If
    
        If IsNumeric(Cells(x, 13)) Then
        Smt = Cells(x, 13).Value
        ElseIf IsError(Cells(x, 13)) Then
        GoTo EndLine
        Else
        GoTo EndLine
        End If
    
    For y = 16 To LastRow
        
        If Cells(y, 14) = x Then
        
        Smt = Smt + Cells(y, 13).Value
        
        End If
        
    Next y
    
    Cells(x, 15).Value = Smt
    
EndLine:
    
    Next x