Sum Duplicated Cells & Then Delete

[nwentling5]

Hello,<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
I have read over numerous threads on how to do this, but I am still not able to piece together the correct code to make it work.<o></o>

What I am trying to do is write some VBA code to run through a master part list, add up the duplicated part's quantity values and then delete the duplicated rows that housed the duplicated cells. <o></o>
<o></o>
Essentially, what I have is and what I need it to do is:
<o></o>
<o></o>
*After being populated by other work sheets within the workbook
Part Name: Quantity Required:<o></o>
Knob 6<o></o>
Wheel 4<o></o>
Hub 3<o></o>
Knob 5<o></o>
Wheel 3<o></o>
<o></o>
*Click Update Button
<o></o>
Part Name: Quantity Required:<o></o>
Knob 11<o></o>
Wheel 7<o></o>
Hub 3
<o></o>
<o></o>
I must note that I am using 2007 Excel and the loops need to be able to work dynamically since the master list will be updated regularly from other worksheets.
<o></o>
<o></o>
Also I have looked at pivot tables and I have messed around with them, but I wasn't able to create exactly what I was looking for.
<o></o>
<o></o>
If anyone can provide me a direction or some basic code on achieving this it would be greatly appreciated! I feel like it is probably something easy to code in VBA, but I have worked myself into a confused & lost state<?xml:namespace prefix = v ns = "urn:schemas-microsoft-com:vml" /><v:shapetype id=_x0000_t75 stroked="f" filled="f" path="m@4@5l@4@11@9@11@9@5xe" oreferrelative="t" o:spt="75" coordsize="21600,21600"> <v:stroke joinstyle="miter"></v:stroke><v:formulas><v:f eqn="if lineDrawn pixelLineWidth 0"></v:f><v:f eqn="sum @0 1 0"></v:f><v:f eqn="sum 0 0 @1"></v:f><v:f eqn="prod @2 1 2"></v:f><v:f eqn="prod @3 21600 pixelWidth"></v:f><v:f eqn="prod @3 21600 pixelHeight"></v:f><v:f eqn="sum @0 0 1"></v:f><v:f eqn="prod @6 1 2"></v:f><v:f eqn="prod @7 21600 pixelWidth"></v:f><v:f eqn="sum @8 21600 0"></v:f><v:f eqn="prod @7 21600 pixelHeight"></v:f><v:f eqn="sum @10 21600 0"></v:f></v:formulas><vath o:connecttype="rect" gradientshapeok="t" o:extrusionok="f"></vath><o:lock aspectratio="t" v:ext="edit"></o:lock></v:shapetype>.<o></o>
<o></o>

Thanks!<o></o>

 

[nwentling5]

I am running the windows 2007 version of excel. I have checked all my secruity settings and made sure everything was good in that area. I have no idea why it isn't working.

When I step through the code it seems as if it is working fine, but it just isn't updating on the sheet. Could you possibly attach your test workbook and see if I can run it and see if it works there?

 

[MickG]

Try this:-
Scrip Dic.xls

 

[nwentling5]

I apologize for a late response. I have finally gotten a chance to come back and work on this project again.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
I downloaded your script and it works perfectly! However, when I try to adapt it to my actual worksheet and have it add up a different column I keep getting: "Run-Time error'9' Subscript out of Range".<o></o>
<o></o>
Within my actual worksheet I have the first column as "Part Name" and 4 columns over in Column E I have "Quantity Required". It is exactly the same concept, just adding up a column that is 4 columns over. <o></o>
<o></o>
I've tried reverse engineering your code several times, but I still have not been able to get it to work properly. I believe I am doing the off-set incorrectly but I am not sure. <o></o>
<o></o>
My latest attempt:<o></o>

Dim Rng As Range, Dn As Range
Dim nRng As Range
Dim Q
Set Rng = Range(Range("A3"), Range("A" & Rows.Count).End(xlUp))
    With CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            .Add Dn.Value, Array(Dn, Dn.Offset(, 4))
        Else
            Q = .Item(Dn.Value)
            Q(1) = Q(1) + Dn.Offset(, 1)
            Q(0).Offset(, 1) = Q(1)
            .Item(Dn.Value) = Q
                If nRng Is Nothing Then
                     Set nRng = Dn
                Else
                    Set nRng = Union(nRng, Dn)
                End If
        End If
Next
End With
If Not nRng Is Nothing Then
nRng.EntireRow.Delete
End If
MsgBox "Run!!"

<o></o>
<o></o>
Where am I going wrong? Thanks for the assistance so far MickG. I feel like we are so close to finally solving this issue!<o></o>

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG02Aug57
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
        [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
            .Add Dn.Value, Array(Dn, Dn.Offset(, 4))
        [COLOR="Navy"]Else[/COLOR]
            Q = .Item(Dn.Value)
            Q(1) = Q(1) + Dn.Offset(, 4)
            Q(0).Offset(, 4) = Q(1)
            .Item(Dn.Value) = Q
                [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                     [COLOR="Navy"]Set[/COLOR] nRng = Dn
                [COLOR="Navy"]Else[/COLOR]
                    [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
                [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] If
MsgBox "Run!!"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[nwentling5]

I put the above code in the test spreadsheet with values going down the 4th column and I recieved the error: "Run-Time Error '9' Subscript out of Range". And it highlighted the line: "Q(0).Offset(, 4) = Q(1)".

 

[nwentling5]

Okay I got it working on the test excel worksheet fine, but when I bring it over to my actual spread sheet I now get this error: Run-Time Error '13' Type Mismatch.

You can downlaod the actual spread sheet here:
http://dl.dropbox.com/u/8986524/Parts List 5.xlsm

 

[nwentling5]

Well I figured out why mine was not working and the test spreadsheet was. I had "Option Base 1" at the top of my code. Woops.

Thanks for your patience and all of your assistance MickG!