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

[teethebuilder18]

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

 

[Fluff]

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?

 

[MickG]

Try this for results starting "D1".

[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

 

[teethebuilder18]

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.

 

[teethebuilder18]

I apologize for my lack of VBS knowledge Mick. Do I add this code to the end of the code that I already have or use this instead?

 

[Fluff]

Where you have Division in col B is the corresponding cell in col D blank?

 

[teethebuilder18]

Where you have Division in col B is the corresponding cell in col D blank?

Yes it is

 

[Fluff]

Where do you want the results?
Or do you just want to delete the entire row of the duplicates?