Using VBA to Sum rows

[junfanbl]

I am trying to put together a macro that will sum rows based on certain criteria.

The criteria is a column with Group IDs in them. I need to sum up each row with the same Group ID in it together.

So If:

Grp IDs Count
1 10
3 12
4 2
1 13
1 5
4 6
4 100

So I would need to sum up every row that has the same group ID in it, for each group ID.

How could I go about doing this?

[NateBrei]

Can you sort the data by Group ID? If so, then you can simply use the Automatic SubTotal feature of Excel. It can be found in the Data ribbon, SubTotal button in the Outline section on the right.

If the data are going to change (i.e. this needs to occur multiple times on this sheet or multiple files), then you can create a macro similar to this below. I've commented the code so you can see what it does. This presupposes that the Grp ID data begin in cell A2 with the values to sum in the corresponding cells of column B.

Hope this helps.

Nate

Sub CreateSubtotals()
    Dim lngLastRow As Long
    
    'Removes any Subtotals in the region of your data.  Does NOT cause
    '   an error is there is no Subtotals
    Range("A2").RemoveSubtotal
    
    'Determines and stores the last data row for use in the Sort method
    lngLastRow = Range("A2").End(xlDown).Row
    
    With ActiveSheet.Sort
        'Clears any previously defined sort fields
        .SortFields.Clear
        'Sets the sort parameters (which column, asc/desc, etc.)
        .SortFields.Add Key:=Range("A2"), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        'Sets the range of the data to sort
        .SetRange Range("A2:B" & lngLastRow)
        'Advices there are headers to use
        .Header = xlYes
        'Don't really need the next3 statements unless you change one of them from
        '   the default
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        'Applies the sort (actually does it)
        .Apply
    End With
    
    'Creates the Subtotals by Groups based on changes in the data of
    '   the first column
    Range("A2").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(2), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    
    'Uses the Outline to show only the Subtotals
    ActiveSheet.Outline.ShowLevels RowLevels:=2
End Sub

[westconn1]

you can also use a worksheetformula (sumif) in VBA

or you can use ADO to read the worksheet as a database, using SQL query to put results into recordsets

[Kevin_UK]

Hi junfanbl

I am new to this forum and learning VB for Excel. Here is my solution, I will be probably get shot down in flames by the more seasoned pro's on here!

I am assuming that your data is in A1:B8. The following code extracts the unique IDs to column D and then uses the Sumif in column E.

Sub SumRows()
    
    'Extract the unique Group IDs to column D
    With Sheet1.Range("A1", Range("A1").End(xlDown))
    
        .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("D1"), Unique:=True
        .Range("D1") = "Group IDs"

    End With
    
'SUMIF part
Dim x As Long
Dim grpID As Range
Dim CountRng As Range
Dim lrow As Long

Set grpID = Range("A2", Range("A2").End(xlDown)) 'Range A2:A8
Set CountRng = Range("B2", Range("B2").End(xlDown)) 'Range B2:B8
lrow = Cells(Rows.Count, 4).End(xlUp) - 1 'Count the number of unique ids for the For Next loop

    For x = 1 To lrow
    
        Cells(x + 1, 5) = WorksheetFunction.SumIf(grpID, Cells(x + 1, 4), CountRng)
    
    Next x
    
End Sub