vba to consolidate and sum duplicate row items

[solidENM]

Hello,
I have a parts list, and it shows cut lengths and pieces needed to build a unit. I need some help condensing all duplicates into one line items with total length needed.
the formula would be:
Column B x Column E, and then sum and condense all unique items in column D into one line each, qty 1 with total length of all like units.

I do have other items on these parts lists, screws, fittings, etc. They are all blank in column E, only the planks have a length entered in column E. Column H is the next blank column if that matters at all.


example layout below.

col. a col. b col. c col. d col. e
[TABLE="width: 665"]
<colgroup><col span="2"><col><col><col></colgroup><tbody>[TR]
[TD]ITEM NO.[/TD]
[TD]QTY.[/TD]
[TD]Description[/TD]
[TD]Part Number[/TD]
[TD]Length[mm][/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]1[/TD]
[TD]Oak[/TD]
[TD]04024[/TD]
[TD]1346[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]2[/TD]
[TD]Oak[/TD]
[TD]04024[/TD]
[TD]1346[/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]2[/TD]
[TD]Mahogany[/TD]
[TD]05599[/TD]
[TD]1346[/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD]1[/TD]
[TD]Oak [/TD]
[TD]04024[/TD]
[TD]1267[/TD]
[/TR]
[TR]
[TD]5[/TD]
[TD]1[/TD]
[TD]Mahogany[/TD]
[TD]05599[/TD]
[TD]305[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]


[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]



the desired output would be:
(col. a) (col. b) (col. c) (col. d) (col. e)
[TABLE="width: 665"]
<colgroup><col span="2"><col><col><col></colgroup><tbody>[TR]
[TD]ITEM NO.[/TD]
[TD]QTY.[/TD]
[TD]Description[/TD]
[TD]Part Number[/TD]
[TD]Length[mm][/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]1[/TD]
[TD]Oak [/TD]
[TD]04024[/TD]
[TD]5305[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]1[/TD]
[TD]Mahogany[/TD]
[TD]05599[/TD]
[TD]2997[/TD]
[/TR]
</tbody>[/TABLE]

 

[JoeMo]

Assuming your header "ITEM NO." is in A1, this will place the consolidated data beginning in G1 on the same sheet.

Sub Consolidate()
Dim R As Range, c As Range
Set R = Range("A1:E" & Cells(Rows.Count, "D").End(xlUp).Row)
Application.ScreenUpdating = False
Columns("G:K").ClearContents
R.Columns(4).AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("J1"), unique:=True
Range("G1").Resize(1, 5).Value = Range("A1:E1").Value
For Each c In Range("G2:G" & Cells(Rows.Count, "J").End(xlUp).Row)
    c.Value = c.Row - 1
Next c
Range("H2:H" & Cells(Rows.Count, "J").End(xlUp).Row).Value = 1
For Each c In Range("I2:I" & Cells(Rows.Count, "J").End(xlUp).Row)
    c.Value = Evaluate("INDEX(" & R.Columns(3).Address & ",MATCH(" & c.Offset(0, _
        1).Address & "," & R.Columns(4).Address & ",0))")
Next c
For Each c In Range("K2:K" & Cells(Rows.Count, "J").End(xlUp).Row)
    c.Value = Evaluate("SUMPRODUCT(--(" & R.Columns(4).Address & "=" & _
        c.Offset(0, -1).Address & ")," & R.Columns(2).Address & "," & _
        R.Columns(5).Address & ")")
    c.Value = c.Value
Next c
Application.ScreenUpdating = True
End Sub

 

[solidENM]

Hi JoeMo,
Thanks for the reply. I had just left on vacation when you originally posted, and today is my first day back. I have columns A-I filled out, so I shifted your code to start in Column J. I am having some other issues with this though. I noticed you have a line to make value = 1, and I would need this to be a true total.

Im thinking it would be best if the macro could create a new Sheet, paste this copied info to there, get correct qty from first sheet for matching items, and then delete the original sheet. I have played around with merging the offset columns into the main columns, but its been troublesome. values with a qty >0 in Column E would need to be Qty1 in col B. Everything else would have to be the matching value off the original sheet.

Thanks a lot for helping out, you have brought me to a great starting point. If you or anyone can help me further, that would speed things along. I am more comfortable learning from viewing code, as I can manipulate that further if needed. Its new tricks I need tips and pointers on.



Sub Consolidate()
'
' Consolidate Macro
'


Dim R As Range, c As Range
Set R = Range("A1:E" & Cells(Rows.Count, "D").End(xlUp).Row)
Application.ScreenUpdating = False
Columns("J:N").ClearContents
R.Columns(4).AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("M1"), unique:=True
Range("J1").RESIZE(1, 5).Value = Range("A1:E1").Value
For Each c In Range("J2:J" & Cells(Rows.Count, "M").End(xlUp).Row)
c.Value = c.Row - 1
Next c
Range("K2:K" & Cells(Rows.Count, "M").End(xlUp).Row).Value = 1
For Each c In Range("L2:L" & Cells(Rows.Count, "M").End(xlUp).Row)
c.Value = Evaluate("INDEX(" & R.Columns(3).Address & ",MATCH(" & c.Offset(0, _
1).Address & "," & R.Columns(4).Address & ",0))")
Next c
For Each c In Range("N2:N" & Cells(Rows.Count, "M").End(xlUp).Row)
c.Value = Evaluate("SUMPRODUCT(--(" & R.Columns(4).Address & "=" & _
c.Offset(0, -1).Address & ")," & R.Columns(2).Address & "," & _
R.Columns(5).Address & ")")
c.Value = c.Value
Next c
Application.ScreenUpdating = True
End Sub