vba to condense similar cells into new cell, with total overall quantity.

solidENM

Board Regular
Joined
Feb 23, 2017
Messages
87
Hello,
I have a parts list that has many duplicate items, but different lengths for each piece to be cut at. when referring from this bill of materials to enter into the computer, i only need to enter one line with the total quantity. Each parts list is of varying lengths and random orders. I am hoping to find something that will scrape the list for similar parts and condense them.


Sample below. I would like line item# 1,2, and 3 to be condensed into one line, for total length of 12592mm (that multiplies qty in B2 by length in d2, and sums all similar woods from line c into one line). ideally, it would be great if this pops out the info on a new sheet, but i would be fine with it in column J-- or any column further to the right.


Item #QTYDescriptionPart NumberLength [mm]
14mahoganyMHG8871000
24mahoganyMHG8871299
36mahoganyMHG887566
412white oakWO9921312

<colgroup><col><col><col><col><col></colgroup><tbody>
</tbody>




desired end result
J column K column (or on new sheet)
Mahogany 12592mm
White Oak 15744mm
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
Hi There

assuming you list of wood is in column J and this cantains all unique timbers from your list.

this should do what you require

Code:
Sub total()
lr = Range("A" & Rows.Count).End(xlUp).Row
lr1 = Range("J" & Rows.Count).End(xlUp).Row
    For a = 1 To lr1
        total = 0
        word1 = Range("j" & a)
            For i = 2 To lr
                If Range("C" & i) = word1 Then total = total + Range("B" & i) * Range("E" & i)
            Next
    Range("k" & a) = total
    Next
End Sub

if you want it output into a different sheet, let me know what the sheet name is.

Only thing i was not sure about was if you required the code to pull out all of your unique timbers from the list??

Dave
 
Upvote 0
Hi Squidd, thanks for the quick reply. Yes, I would need the unique timbers pulled out too. I have all the various types of wood on Sheet2. With all the various end finishes, it comes out to 1137 total, so I would like to keep that on its own hidden sheet. Right now, it is used to pull up pricing onto the first page, but we never look at it.

as for the code, it is working great so far. I figure it would be fine if the code spits out doubles, since I could just expand the macro to delete duplicates in columns J and K.
 
Upvote 0
Also, it would be great is 0 qty items would be removed. I have fasteners and other hardware on the lines below, they have no value for the Length in column E. They only have qty in B and description and part number in c & d.


you have already gotten me further than i could figure out by myself, thank you very much. I found it hard to describe what I was looking for, and the search on the website wasn't working too great as a result.
 
Upvote 0
Hi Again

Try this code, i need to tidy it a bit if it works.

create yourself a sheet called "sheet3" for test purposes.

then run this code from your main sheet

Code:
Sub total()

LR = Range("A" & Rows.Count).End(xlUp).Row
Range("C2:C" & LR).Copy
Range("'SHEET3'!A1").PasteSpecial

lr2 = Range("'SHEET3'!A" & Rows.Count).End(xlUp).Row
        With Sheets("sheet3").Columns("A:A")
            .Range("A1:A" & lr2).RemoveDuplicates Columns:=1, Header:=xlNo
            .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        End With

lr1 = Range("'SHEET3'!A" & Rows.Count).End(xlUp).Row
    For a = 1 To lr1
        total1 = 0
        word1 = Range("'SHEET3'!A" & a)
            For i = 2 To LR
                If Range("C" & i) = word1 Then total1 = total1 + Range("B" & i) * Range("E" & i)
            Next
    Range("'SHEET3'!B" & a) = total1
    Next
End Sub

should pull out all the unique timbers from your list and put into sheet 3 column A then put the total into column B.

we can ann into the code also that if the total = 0 then Dont put into the list, but try this 1st, then i will add it and tidy things up.

Also if it works, let me know what sheet you want the output put into.

cheers

dave
 
Upvote 0
Hi

I got to sign off now.(couple of hours)

But like i said before, create sheet3 and run this code from your main sheet, should now work and then delete all timbers that total 0.
Code:
Sub total()

LASTROW = Range("A" & Rows.Count).End(xlUp).Row
Range("C2:C" & LASTROW).Copy
Range("'SHEET3'!A1").PasteSpecial

lr2 = Range("'SHEET3'!A" & Rows.Count).End(xlUp).Row
        With Sheets("sheet3").Columns("A:A")
            .Range("A1:A" & lr2).RemoveDuplicates Columns:=1, Header:=xlNo
            .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        End With

lr1 = Range("'SHEET3'!A" & Rows.Count).End(xlUp).Row
    For a = 1 To lr1
        total1 = 0
        word1 = Range("'SHEET3'!A" & a)
            For i = 2 To LASTROW
                If Range("C" & i) = word1 Then total1 = total1 + Range("B" & i) * Range("E" & i)
            Next
    Range("'SHEET3'!B" & a) = total1
    Next
    Sheets("SHEET3").Activate
        For B = Range("'SHEET3'!A" & Rows.Count).End(xlUp).Row To 1 Step -1
            If Range("'SHEET3'!B" & B).Value = 0 Then Rows(B).EntireRow.Delete
        Next B
End Sub

still got to tidy iot up, sorry, was in a bit of a rush.

Dave
 
Upvote 0
I keep getting an error towards the end. If Range("C" & i) = word1 Then total1 = total1 + Range("B" & i) * Range("E" & i)

the blue part keeps coming back highlighted, with error "type mismatch"

it is pasting the info onto sheet3 after I created that sheet. This code alone isnt updating anything on the main sheet though.
 
Upvote 0
found out what the error was with the above post. I had a formula in cell d1 (for page number). after deleting that cell it worked great.

Thanks for all the help SQUIDD.

would it be difficult to also have column D paste over onto the next page? Also, would it be possible to have the new sheet auto generate? Right now its only working if i make a Sheet3 first.
 
Upvote 0
I can do column D no problem, can also apply your headers easily too.

Not sure what you mean by having sheet 3 auto generate, i mean, i know what you want, you want the code to generate sheet3.

BUT

Why can you not simply have sheet3 always in your workbook??

If it is because you dont want users to see it, probably best if you simply have the code to display the sheet(unhide) and then as soon as the user clicks a different sheet we could make the sheet hide again automatically.

Let me know.

Will add the other functions required and post back the code.


Dave
 
Upvote 0
Hi

Ok

this should do the trick for you. This makes sheet 3 visible at the end of the code. then the code posted under , put that into sheet3 module, when you click a different sheet it will re-hide sheet 3.

let me know if you need any help OR this option will not work for you.



Code:
Sub total()
Sheets("sheet3").Columns("A:C").ClearContents
Range("C1:E" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Range("'SHEET3'!A1").PasteSpecial
    With Sheets("sheet3").Columns("A:C")
        .Range("A1:C" & Range("'SHEET3'!A" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
        .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    End With
        For a = 2 To Range("'SHEET3'!A" & Rows.Count).End(xlUp).Row
            total1 = 0
            word1 = Range("'SHEET3'!A" & a)
                For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
                    If Range("C" & i) = word1 Then total1 = total1 + Range("B" & i) * Range("E" & i)
                Next
                Range("'SHEET3'!C" & a) = total1
        Next
    Sheets("SHEET3").Activate
For B = Range("'SHEET3'!A" & Rows.Count).End(xlUp).Row To 2 Step -1
    If Range("'SHEET3'!C" & B).Value = 0 Then Rows(B).EntireRow.Delete
Next B
Sheets("Sheet3").Visible = True
End Sub


create sheet3, right click on the tab and click view code, paste this into there.

Code:
Private Sub Worksheet_Deactivate()
Sheets("Sheet3").Visible = False
End Sub

Dave
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,487
Messages
6,113,938
Members
448,534
Latest member
benefuexx

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