Sum of values multiplied by corresponding value in other table

[RobbertH]

Hi,

I'm looking for a way to sum the results of values multiplied by values with a similar key.

Below a simplified Example:
sheet 1:
A B
1 P1 10
2 P2 15
3 P3 5
4 P4 1
5 P5 20
6 P6 10

sheet 2:
A B
1 -
2 P1 1.50
3 P2 2.00
4 P6 0.50
5 P3 1.00
6 P4 2.50
7 P5 3.00

Result should be: 117.5 (B1*E2+B2*E3+B3*E5+B4*E6+B5*E7+B6*E4)

Hope this is clear enough and you can help

 

[Rick Rothstein]

Hi,

I'm looking for a way to sum the results of values multiplied by values with a similar key.

Below a simplified Example:
sheet 1:
A B
1 P1 10
2 P2 15
3 P3 5
4 P4 1
5 P5 20
6 P6 10

sheet 2:
A B
1 -
2 P1 1.50
3 P2 2.00
4 P6 0.50
5 P3 1.00
6 P4 2.50
7 P5 3.00

Result should be: 117.5 (B1*E2+B2*E3+B3*E5+B4*E6+B5*E7+B6*E4)

Hope this is clear enough and you can help

Any chance the tables can be sorted on Column A to make things easier?

 

[RobbertH]

No im afraid i cant

 

[Rick Rothstein]

No im afraid i cant

Okay, in your first message, you said "Below a simplified Example"... how simplified was it? Are the values in Column A on the two sheets really the letter "P" followed by a number (with no gaps in the numerical sequence from the minimum to the maximum numbers used)?

 

[RobbertH]

The values in column A are all text. Some cells in the range are empty but all not empty are text only (with spaces though)

 

[Rick Rothstein]

The values in column A are all text. Some cells in the range are empty but all not empty are text only (with spaces though)

Give the following UDF a try. It takes two arguments... the range of value on Sheet1 (for your posted example, A1:B6) and the range of values on Sheet2 (for your posted example, A2:B7).

Function KeySumProduct(Rng1 As Range, Rng2 As Range)
  Dim X As Long, R As Range, Coll1 As New Collection, Coll2 As New Collection
  If Rng1.Rows.Count = Rng2.Rows.Count Then
    For Each R In Rng1.Rows
      If Len(R.Cells(1).Value) Then Coll1.Add R.Cells(2).Value, R.Cells(1).Value
    Next
    For Each R In Rng2.Rows
      If Len(R.Cells(1).Value) Then Coll2.Add R.Cells(2).Value, R.Cells(1).Value
    Next
    For Each R In Rng1.Columns(1).Cells
      KeySumProduct = KeySumProduct + Coll1(R.Value) * Coll2(R.Value)
    Next
  End If
End Function

HOW TO INSTALL UDFs
------------------------------------
If you are new to UDFs, they are easy to install and use. To install it, simply press ALT+F11 to go into the VB editor and, once there, click Insert/Module on its menu bar, then copy/paste the above code into the code window that just opened up. That's it.... you are done. You can now use KeySumProduct just like it was a built-in Excel function. For example,

=KeySumProduct(Sheet1!A1:B6,Sheet2!A2:B7)

If you are using XL2007 or above, make sure you save your file as an "Excel Macro-Enabled Workbook (*.xlsm) and answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

 

[RobbertH]

Thanks! That's a pretty solution!

It works fine for my example given. However, how would i addapt the UDF to make it work for different table lengths and empty rows in the table in sheet 1? This doesn't seem to work yet.
Thanks for your help! A true MVP!

 

[Rick Rothstein]

It works fine for my example given. However, how would i addapt the UDF to make it work for different table lengths and empty rows in the table in sheet 1? This doesn't seem to work yet.

The data that is to be multiplied together need to have the same element count, but I had forgotten that the ranges can differ in size due to the possibility of empty rows. So, rather than checking if the ranges are the same size, I should have checked if the two Collection had the same Count. See if this works for you...

Function KeySumProduct(Rng1 As Range, Rng2 As Range)
  Dim X As Long, R As Long, vArr1 As Variant, vArr2 As Variant
  Dim Coll1 As New Collection, Coll2 As New Collection
  vArr1 = Rng1
  vArr2 = Rng2
  For R = 1 To UBound(vArr1)
    If Len(vArr1(R, 1)) Then Coll1.Add vArr1(R, 2), vArr1(R, 1)
  Next
  For R = 1 To UBound(vArr2)
    If Len(vArr2(R, 1)) Then Coll2.Add vArr2(R, 2), vArr2(R, 1)
  Next
  If Coll1.Count = Coll2.Count Then
    For R = 1 To UBound(vArr1)
      If Len(vArr1(R, 1)) Then
        KeySumProduct = KeySumProduct + Coll1(vArr1(R, 1)) * Coll2(vArr1(R, 1))
      End If
    Next
  End If
  Set Coll1 = Nothing
  Set Coll2 = Nothing
End Function

Note that I chose to be "safe" and added code to set the Collections to Nothing once I was done with them... plus I decided to speed things up somewhat by reading the ranges into memory and working with them there instead of repeatedly reaching back to the cells of the ranges over and over again.

 

[RobbertH]

Thanks Rick,

I got it working now. I changed the UDF slightly to allow me to also work sideways

Function KeySumProduct(Rng1 As Range, Rng2 As Range, Col As Integer)
  Dim X As Long
  Dim R As Long
  Dim vArr1 As Variant
  Dim vArr2 As Variant
  Dim Coll1 As New Collection
  Dim Coll2 As New Collection
  
  vArr1 = Rng1
  vArr2 = Rng2
  For R = 1 To UBound(vArr1)
    If Len(vArr1(R, 1)) Then Coll1.Add vArr1(R, Col), vArr1(R, 1)
  Next
  For R = 1 To UBound(vArr2)
    If Len(vArr2(R, 1)) Then Coll2.Add vArr2(R, 2), vArr2(R, 1)
  Next
  If Coll1.Count = Coll2.Count Then
    For R = 1 To UBound(vArr1)
      If Len(vArr1(R, 1)) Then
        KeySumProduct = KeySumProduct + Coll1(vArr1(R, 1)) * Coll2(vArr1(R, 1))
      End If
    Next
  End If
  Set Coll1 = Nothing
  Set Coll2 = Nothing
End Function

Is there a way to not having to make tho table tabels containing the exact same text values. So table 1 contains text (keys) that are not present in table 2. When not present in table two it should assume 0?

This would make the code perfect..

Thanks for your help!

 

[Rick Rothstein]

I got it working now. I changed the UDF slightly to allow me to also work sideways


Is there a way to not having to make tho table tabels containing the exact same text values. So table 1 contains text (keys) that are not present in table 2. When not present in table two it should assume 0?


This would make the code perfect..

I think this will do what you want (please test it and let me know)...

Function KeySumProduct(Rng1 As Range, Rng2 As Range, Col As Long)
  Dim X As Long
  Dim R As Long
  Dim vArr1 As Variant
  Dim vArr2 As Variant
  Dim vArr As Variant
  Dim Coll1 As New Collection
  Dim Coll2 As New Collection
  
  vArr1 = Rng1
  vArr2 = Rng2
  For R = 1 To UBound(vArr1)
    If Len(vArr1(R, 1)) Then Coll1.Add vArr1(R, Col), vArr1(R, 1)
  Next
  For R = 1 To UBound(vArr2)
    If Len(vArr2(R, 1)) Then Coll2.Add vArr2(R, 2), vArr2(R, 1)
  Next
  If Coll1.Count > Coll2.Count Then
    vArr = vArr1
  Else
    vArr = vArr2
  End If
  On Error Resume Next
  For R = 1 To UBound(vArr)
    KeySumProduct = KeySumProduct + Coll1(vArr(R, 1)) * Coll2(vArr(R, 1))
  Next
  On Error GoTo 0
  Set Coll1 = Nothing
  Set Coll2 = Nothing
End Function