how add the rows with the same value in a colClosed

Question

Hi Friends, 

I'm trying to make a macro to have a summary worksheet. 
- My purpose is to add the data in the rows  which has the same ID number in the first column. 
- In one of my worksheet (temporary worksheet, after obtaining the summary sheet my main macro deletes this tempo worksheet) the data has 5 columns. 
First column is ID Numbers; second one is ID Names; third, forth and fifth ones discrete numbers for different .
- So my macro needs to add up the values in the column 3,4,and 5 which has the same ID Name.
For Example if the data is as below
Col1-Col2-Col3-Col4-Col5
11    AAA    10     0      20
12    BBB     2     12      0
13    CCC    4      5       9
11    AAA     5      7      10

the summary sheet should be

Col1-Col2-Col3-Col4-Col5
11    AAA    15     7      30
12    BBB     2     12      0
13    CCC    4      5       9

- I cannot use the pivot table because I want it automated and no interaction should be necessary when new data (into rows) added or refreshened. So I really need the code.
I've got this code below but it does not search and combine the rows if data rows added at the end or if there are empty rows between the  data rows.

Thank you for your help, cannot wait how to solve this. :)

Dim rInput As Range
Dim oDic As Object
Dim nTotal(), vInput()
Dim i As Long, j As Long, k As Long

With Application
.ScreenUpdating = False
Sheets("NotINuse3").Activate
Set rInput = Range("A1", Range("E65536").End(xlUp))

vInput = rInput.Value
ReDim nTotal(1 To UBound(vInput, 1), 1 To 5)

Set oDic = CreateObject("Scripting.Dictionary")
With oDic
   For i = 1 To UBound(vInput, 1)
       If Not .Exists(vInput(i, 1)) Then
            j = j + 1
            For k = 1 To 5
                nTotal(j, k) = vInput(i, k)
            Next k
            .Add vInput(i, 1), j
        ElseIf .Exists(vInput(i, 1)) Then
            For k = 2 To 5         'Start it from K=3 because we don't want to add up the machine numbers
                nTotal(.Item(vInput(i, 1)), k) = nTotal(.Item(vInput(i, 1)), k) + vInput(i, k)
            Next k
        End If
    Next i
End With


Columns("A:F").Clear
Range("A1").Resize(j, 5) = nTotal

Application.ScreenUpdating = True
End With

venkat1926 · Answer

the first sheet is called "sheet1"
the second sheet is called "summary"

copy all the macros/function in the standard module

BUT RUN ONLY "A_overall_macro"

prefix A is given so that this macro will be first in the list.
the macros are dynamic that is you can have as many rows or columns.

TRY THIS ON YOUR TRUNCATED DATA AS GIVEN IN THE POST. 

Dim r As Range, r1 As Range, c1 As Range, x As String, s As Double
Dim j As Long, k As Long
Dim m As Long, n As Long, rfilt As Range, ssum As Double


Sub idname()
With Worksheets("sheet1")
Set r = Range(.Range("A1"), .Range("A1").End(xlDown).Offset(0, 1))
r.AdvancedFilter action:=xlFilterCopy, copytorange:=Worksheets("summary").Range("A1"), _
    unique:=True
 End With
End Sub



Function Sum_Visible_Cells(Cells_To_Sum As Object)
 'reference https://support.microsoft.com/en-us/help/150363
 Dim cell As Range, total As Double
       Application.Volatile
       For Each cell In Cells_To_Sum
           If cell.Rows.Hidden = False Then
               If cell.Columns.Hidden = False Then
                   total = total + cell.Value
               End If
           End If
       Next
       Sum_Visible_Cells = total
 End Function


Sub summingup()
         With Worksheets("sheet1")
j = .Range("A1").End(xlToRight).Column
m = Worksheets("summary").Range("A1").End(xlDown).Row
For k = 3 To j
For n = 2 To m
    With Worksheets("summary")
'msgbox Cells(n, 2).Address
x = .Cells(n, 2)
'msgbox x
  End With
Set r = .Range("A1").CurrentRegion
'msgbox r.Address
r.Cells.AutoFilter field:=2, Criteria1:=x
ssum = Sum_Visible_Cells(Range(.Cells(2, k), .Cells(2, k).End(xlDown)))
'msgbox ssum
    With Worksheets("summary")
.Cells(n, k) = ssum
    End With
r.AutoFilter
Next n
Next k
End With
End Sub


Sub A_overall_macro()
 Worksheets("summary").Cells.Clear
idname
summingup
End Sub



post your comments

tugbakj · Answer

Thank you so much I am working on it , I think it will be a winner.

Thanks a lot really!

T.J.

How add the rows with the same value in a col

2 responses

Subscribe To Our Newsletter!