Combining Duplicate Rows and Summing the Values using VBA - Beginner Question

teethebuilder18

New Member
Joined
Jul 18, 2018
Messages
4
Hi All,

I am not sure that this is the correct place to post this, but I have a VBA question.
I found a set of code online to do what I desire, but I need to modify it to suit my needs. What I am doing is this:
I have a set of Names and values separated in my excel sheet as "Divisions" ex:
Division 290-01
Board - 1
Board - 2
Board - 3
Stud - 4
Stud - 5
Stud - 6

In the example above, the item (board; stud) and the number next to it (1-6) are in separate cells next to each other. I found a section of code online that allows me to consolidate repeating names and sum the values like such:
Division 290-01
Board - 6
Stud - 15

The problem I'm having is that I have Multiple divisions, and have to run the code over again for each division.
Example:
Division 290-01
Board - 1
Board - 2
Board - 3
Stud - 4
Stud - 5
Stud - 6

Division 300-01
Board - 1
Board - 2
Board - 3
Stud - 4
Stud - 5
Stud - 6

My goal is to create a section of code that works through the whole sheet to consolidate the items by Division like this:
Division 290-01
Board - 6
Stud - 15

Division 300-01
Board - 6
Stud - 15

The code I am using right now has to be run for each division, and as you could imagine this is very time consuming. Thanks in advance for your help. Please see below, this is the code I am using to run each division individually:


Sub CombineRows()
'Update 20130829
Dim WorkRng As Range
Dim Dic As Variant
Dim arr As Variant
On Error Resume Next
xTitleId = "KutoolsforExcel"
Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
Set Dic = CreateObject("Scripting.Dictionary")
arr = WorkRng.Value
For i = 1 To UBound(arr, 1)
Dic(arr(i, 1)) = Dic(arr(i, 1)) + arr(i, 2)
Next
Application.ScreenUpdating = False
WorkRng.ClearContents
WorkRng.Range("A1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)
WorkRng.Range("B1").Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)
Application.ScreenUpdating = True
End Sub
 

Excel Facts

When they said...
When they said you are going to "Excel at life", they meant you "will be doing Excel your whole life".
Hi & welcome to MrExcel.
Does your data have blank lines between each division?
If not is Division in col A with 290-01 in col B, or is it all in Col A?
 
Upvote 0
Try this for results starting "D1".
Code:
[COLOR="Navy"]Sub[/COLOR] MG18Jul14
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] R [COLOR="Navy"]As[/COLOR] Range, rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range("A:A").SpecialCells(xlCellTypeConstants)
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
rw = 0
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dn
        [COLOR="Navy"]If[/COLOR] Not .Exists(R.Value) [COLOR="Navy"]Then[/COLOR]
            .Add R.Value, R.Offset(, 1).Value
        [COLOR="Navy"]Else[/COLOR]
            .Item(R.Value) = .Item(R.Value) + R.Offset(, 1).Value
        [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] R
    
    Range("D1").Offset(rw).Resize(.Count, 2) = Application.Transpose(Array(.Keys, .items))
    rw = rw + .Count + 1
    .RemoveAll
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
There are no spaces between divisions.
The division and the numbers following ex: Division 290-01; are in the same cell. Division is in column B, name (board; stud) are in column D, and the quantities for each name is in column F.
 
Upvote 0
Where you have Division in col B is the corresponding cell in col D blank?
 
Upvote 0
Where do you want the results?
Or do you just want to delete the entire row of the duplicates?
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,177
Members
453,021
Latest member
Justyna P

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top