VBA/Excel - Adding cell values if values of adjacent cells match

Question

I'm working with a spreadsheet that tracks monthly risk values for a variety of storage locations globally.

My table has three columns, with a separate row for each individual storage location detailing Column A: Month (April, May, or June) Column B: Location of storage facility (country) Column C: Monthly risk value for the storage location

My task is to calculate the average risk value for the aggregate value of storage locations per country for each of the above months. There are about 12000 storage locations spread across 75 or so countries, hence I am looking to automate.

I would effectively need something equivalent to "If the values in adjacent cells 2A (month) and 2B (country) match the values from adjacent cells 1A and 1B [qualifying the corresponding risk value is for a location in the same month/country], then add the value in cell 2C to the value in cell 1C; if not, use the value from current cell 2C". The table is filtered by month/country as it is, so the formula should return the value from cell 2C if the adjacent cells do not match, as this means that we are now looking at data for the next month/country, which should then aggregate again from 0.

By no means am I looking for someone to write this for me, but if anyone could point me in the direction of a function(s)/VBA tool that could work for this, that would be much appreciated.

Thanks!

Answer 1

Please, try the next code. It needs a reference to 'Microsoft Scripting runtime'. I will also post a piece of code, able to add it automatically:

Sub sumUniqueConcatenatedCases()
  Dim sh As Worksheet, sh1 As Worksheet, lastR As Long
  Dim arr, arrFin, arrKey, i As Long, dict As New Scripting.Dictionary
  
  Set sh = ActiveSheet
  Set sh1 = sh.Next 'you can use here a sheet you need (to return the procesed data)
  lastR = sh.Range("A" & sh.rows.count).End(xlUp).row    'last row of A:A column
  arr = sh.Range("A2:C" & lastR).Value                   'place the range in an array for faster iteration
  For i = 1 To UBound(arr)                               'iterate between the array elements
    If Not dict.Exists(arr(i, 1) & "|" & arr(i, 2)) Then 'if not in dictionary:
        dict.Add arr(i, 1) & "|" & arr(i, 2), arr(i, 3)  'create the key with value from C:C as item
    Else
        dict(arr(i, 1) & "|" & arr(i, 2)) = dict(arr(i, 1) & "|" & arr(i, 2)) + arr(i, 3) 'add C:C value to existing item value
    End If
  Next i
 
  ReDim arrFin(1 To dict.count, 1 To 3)  'reDim the final array in order to keep the dictionary keys and necessary values
  'Place the processed values in final array (arrFin):
  For i = 0 To dict.count - 1
        arrKey = Split(dict.Keys(i), "|")  'split the key, to extract the first two columns strings
        arrFin(i + 1, 1) = arrKey(0): arrFin(i + 1, 2) = arrKey(1) 'place the extracted strings in arrFin
        arrFin(i + 1, 3) = dict.items(i)   'place the item in the third column
  Next
  'drop the processed array result (in the next sheete) at once:
  sh1.Range("A2").Resize(UBound(arrFin), UBound(arrFin, 2)).Value = arrFin
  MsgBox "Ready..."
End Sub

It will return the processed result in the next sheet. The return sheet should be easily adapted to your need, if next one is not convenient. But, such a next sheet must exist ... To automatically add the necessary reference, please run the next code:

Sub addScrRunTimeRef()
  'Add a reference to 'Microsoft Scripting Runtime':
  'In case of error ('Programmatic access to Visual Basic Project not trusted'):
  'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
  '         check "Trust access to the VBA project object model"
  On Error Resume Next
  Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
  If err.Number = 32813 Then
        err.Clear: On Error GoTo 0
        MsgBox "The reference already exists...": Exit Sub
  Else
        On Error GoTo 0
        MsgBox """Microsoft Scripting Runtime"" reference added successfully..."
  End If
End Sub

Run this code, save the workbook (to keep the reference for the future) and only after that run the above one.

The code could be designed to not need such a reference, but it should be good to have the intellisense suggestion, when will try using a dictionary by your own.

Please, test it and send some feedback.

And, please note that next time when ask a question, you should prove that you did, at least, researches . The best approach would be to show us a piece of code, even if it does not do what you need...