Sum values based on unique ID

[briguyUSA]

I have written some VBA code that allows me to filter a spreadsheet to the data I require . I am now looking to add all of the values in a column that have the same unique ID. For example, if there are 4 rows with the same ID of "123456", I want to add up all of their corresponding values to a "sum" row. Any tips on how i might tackle this?

I also won't be able to simply apply a SumIF funciton, as the filter updates with either more or less rows and such.

​

ID​	Values​
123456​	10​
123456​	12​
123456​	14​
123456​	16​
Sum​	52​
987654​	20​
987654​	22​
Sum​	42​
456789​	30​
456789​	50​
456789​	10​
Sum​	90​

 

[Alaa mg]

sum.xlsm

 

[mumps]

The macro works properly for me in the file you uploaded. I forgot to centre the text so the version below takes care of that.

Sub SumValues()
    Application.ScreenUpdating = False
    Dim lRow As Long, i As Long, v As Variant, va As Range, total As Long, desWS As Worksheet
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set desWS = Sheets("Sheet2")
    v = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
    With desWS.Range("A1:B1")
        .Value = Array("id", "va")
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .Exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                With Range("A1")
                    .CurrentRegion.AutoFilter 1, v(i, 1)
                    For Each va In Range("B2:B" & lRow).SpecialCells(xlCellTypeVisible)
                        total = total + va.Value
                    Next va
                    With desWS
                        Range("A2:B" & lRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Interior.ColorIndex = 6
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Interior.ColorIndex = 3
                        With .Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 2)
                            .Value = Array("Sum", total)
                            .Font.Bold = True
                            .Borders.LineStyle = xlContinuous
                            .HorizontalAlignment = xlCenter
                        End With
                    End With
                End With
                total = 0
            End If
        Next i
        Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[Alaa mg]

it's very impressive ! thanks so much for your cooperation

 

[mumps]

You are very welcome.

 

[Alaa mg]

@mumps sorry come back again but I've found problem when I run the macro repeatedly , it also copies repeatedly to the bottom . it should not do that

just do that in one case if there is a new item. with considering if I change the values for items and there is existed in sheet2 then should change the values without copy to the bottom again

 

[mumps]

Try this version. Just run it after any change or addition to the data in Sheet1.

Sub SumValues()
    Application.ScreenUpdating = False
    Dim lRow As Long, i As Long, v As Variant, va As Range, total As Long, desWS As Worksheet
    lRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set desWS = Sheets("Sheet2")
    v = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
    With desWS
        With .UsedRange
            .ClearContents
            .Borders.LineStyle = xlNone
            .Interior.ColorIndex = xlNone
        End With
        With .Range("A1:B1")
            .Value = Array("id", "va")
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
    End With
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .Exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                With Range("A1")
                    .CurrentRegion.AutoFilter 1, v(i, 1)
                    For Each va In Range("B2:B" & lRow).SpecialCells(xlCellTypeVisible)
                        total = total + va.Value
                    Next va
                    With desWS
                        Range("A2:B" & lRow).SpecialCells(xlCellTypeVisible).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
                        .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Interior.ColorIndex = 6
                        .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Interior.ColorIndex = 3
                        With .Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, 2)
                            .Value = Array("Sum", total)
                            .Font.Bold = True
                            .Borders.LineStyle = xlContinuous
                            .HorizontalAlignment = xlCenter
                        End With
                    End With
                End With
                total = 0
            End If
        Next i
        Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[Alaa mg]

@mumps that's better
many thanks again

 

[mumps]

My pleasure.