Sum up value with different keys

Question

Please refer to the attached picture to have a better idea.

I have multiple rows in my worksheet with a group name and a lot of values. Each group shows multiple times in my table. Now I would like to sum values for every group and return them. What is the most efficient way to do this?

Now I have the code to store each row's total value to an array and sum it up like below:

Dim arr() as variant
Dim n as integer
Dim sum as variant

For n = firstrow to lastrow   'assume firstrow and lastrow are known numbers

arr = Range(Cells(n, 3),Cells(n,column.count)).Value 
sum = Workbookfunction.sum(arr)

Next n

Any thoughts will be quite helpful!

Answer 1

Use SUMPRODUCT:

=SUMPRODUCT(($A$7:$A$18=A1)*($B$7:$G$18))

Answer 2

A VBA Array Version

Before using this code adjust the data in the customize section to fit your needs.
The commented blocks starting with ' str1 = " are used for debugging. You can delete them or uncomment them to see some 'subtotals' in the immediate window.

Option Explicit

Sub SumGroups()

'-- Customize BEGIN --------------------
  Const cStrG As String = "B2" 'First cell of the group section
  Const cStrD As String = "B15" 'First cell of the data section
'-- Customize END ----------------------

  Dim oRng As Range
  Dim oRngResults As Range

  Dim arrNames As Variant
  Dim arrData As Variant
  Dim arrResults As Variant

  Dim loNames As Long
  Dim loData As Long
  Dim iDataCol As Integer
  Dim dblResults As Double

  'Debug
  Dim lo1 As Long
  Dim i1 As Integer
  Dim str1 As String
  Dim str2 As String
  Dim dTime As Double

'  'Determine the group names range using the first cell of the data section.
'  Set oRng = Range(cStrG).Resize(Range(cStrD).Rows.End(xlUp).Row - 1, 1)

  'Determine the group names range using the last cell of the group section.
  Set oRng = Range(cStrG).Resize(Range(cStrG).Rows.End(xlDown).Row - 1, 1)
  'Determine the range of the results
  Set oRngResults = oRng.Offset(0, 1)
  'Paste the group names range into an array
  arrNames = oRng

'  str1 = "arrNames:"
'  For lo1 = LBound(arrNames) To UBound(arrNames)
'    str1 = str1 & vbCrLf & lo1 & ". " & Chr(9) & arrNames(lo1, 1)
'  Next
'  Debug.Print str1

  'Determine the data range using resize NOT finished.
'  Set oRng = Range(cStrD).Resize(Cells(Cells.Rows.Count, _
      Range(cStrD).Column).End(xlUp).Row - Range(cStrD).Row + 1, 1)

  'Determine the data range not using resize.
  Set oRng = Range(Cells(Range(cStrD).Row, Range(cStrD).Column), _
      Cells(Cells(Cells.Rows.Count, Range(cStrD).Column).End(xlUp).Row, _
      Cells(Range(cStrD).Row, Cells.Columns.Count).End(xlToLeft).Column))
  'Paste the data range into an array
  arrData = oRng

  Set oRng = Nothing 'Release object variable

'  str1 = "arrData:"
'  For lo1 = LBound(arrData) To UBound(arrData)
'    str2 = ""
'    For i1 = LBound(arrData, 2) To UBound(arrData, 2)
'      str2 = str2 & Chr(9) & arrData(lo1, i1)
'    Next
'    str1 = str1 & vbCrLf & lo1 & "." & str2
'  Next
'  Debug.Print str1

  arrResults = oRngResults

  For loNames = LBound(arrNames) To UBound(arrNames)
    dblResults = 0
    For loData = LBound(arrData) To UBound(arrData)
      If arrNames(loNames, 1) = arrData(loData, 1) Then
        For iDataCol = LBound(arrData, 2) + 1 To UBound(arrData, 2)
          dblResults = dblResults + arrData(loData, iDataCol)
        Next
      End If
    Next
    arrResults(loNames, 1) = dblResults
  Next

'  str1 = "arrResults:"
'  For lo1 = LBound(arrResults) To UBound(arrResults)
'    str1 = str1 & vbCrLf & lo1 & ". " & Chr(9) & arrResults(lo1, 1)
'  Next
'  Debug.Print str1

  oRngResults = arrResults

  Set oRngResults = Nothing 'Release object variable

End Sub

At 50000 rows it calculates in less than a second. The determination of the ranges gave me quite some grief, but I still think they could probably be improved. Would appreciate some feedback regarding the ranges.

Answer 3

I've rewritten the code to use instead of yours. It adds up all the rows between two row indexes, as long as the first cell in each row has a value of "Group A".

Dim firstRow As Integer
Dim lastRow As Integer
Dim currentSum As Integer
Dim currentGroup As String

'Change firstRow and lastRow to the row indexes of the cells you're adding
firstRow = 10
lastRow = 13
currentSum = 0
currentGroup = "Group A"

For n = firstRow To lastRow
    If Cells(n, 1).Value = currentGroup Then
        currentSum = currentSum + Application.sum(Range(Cells(n, 1), Cells(n, 50)))
    End If

    'Put the cell name of where you want the value, instead of B3
    Range("B3").Value = currentSum

    'Change currentGroup to the next group here
Next n