How add the rows with the same value in a col

tugbakj - Oct 13, 2010 at 12:32 PM
 tugbakj - Oct 14, 2010 at 07:10 AM
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
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

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
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

Range("A1").Resize(j, 5) = nTotal

Application.ScreenUpdating = True
End With

2 responses

venkat1926 Posts 1863 Registration date Sunday June 14, 2009 Status Contributor Last seen August 7, 2021 811
Oct 14, 2010 at 07:00 AM
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.


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"), _
 End With
End Sub

Function Sum_Visible_Cells(Cells_To_Sum As Object)
 Dim cell As Range, total As Double
       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
       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
Next n
Next k
End With
End Sub

Sub A_overall_macro()
End Sub

post your comments
Thank you so much I am working on it , I think it will be a winner.

Thanks a lot really!