Excel VBA - How To Sort and Total Data in a Summary Tab

[santa12345]

Hello.
I am trying to do the following.
Lets say I have a order tab.
Main Part # is listed in column A. Qty is next. The Main Part # consists of 4 parts which is columns D - G.
I have the mid and left functions working to populate D-G... and the below screen shot.

What I want to create...is a macro to do the following.
1. Create a summary tab.
2. Get the unique sub parts and total up the qty for each
3. The summary tab would be in the tube,top,bottom,seal order if possible.
4. Total up the qtys per sub part.

Here is the final output I am looking for on the summary tab.

Please let me know if you have any questions.
Any inputs and/or suggestions would be greatly appreciated.

 

[mrshl9898]

This will move the first v down a row and copy the last row into that place then clear it.

Sub CreateSummary()

Dim sht As Worksheet
Dim Lastrow As Long
Dim sht2 As Worksheet
Dim Lastrow2 As Long
Dim rownum As Long

Sheets.Add.Name = "Summary"

Set sht = Sheets("Order")
Lastrow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Set sht2 = Sheets("Summary")

sht2.Range("A1") = "Sub Part"
sht2.Range("B1") = "Total Qty"
sht.Range("D2:D" & Lastrow).Copy sht2.Range("A2")
Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
sht.Range("E2:E" & Lastrow).Copy sht2.Range("A" & Lastrow2 + 1)
Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
sht.Range("F2:F" & Lastrow).Copy sht2.Range("A" & Lastrow2 + 1)
Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
sht.Range("G2:G" & Lastrow).Copy sht2.Range("A" & Lastrow2 + 1)
Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row

sht2.Range("A1:A" & Lastrow2).RemoveDuplicates Columns:=Array(1), Header:=xlYes
sht2.Range("B2").FormulaR1C1 = _
    "=SUMIFS(Order!C,Order!C[2],RC[-1])+SUMIFS(Order!C,Order!C[3],RC[-1])+SUMIFS(Order!C,Order!C[4],RC[-1])+SUMIFS(Order!C,Order!C[5],RC[-1])"
Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
sht2.Range("B2").Copy sht2.Range("B2:B" & Lastrow2)

sht2.Range("A1:B" & Lastrow2).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes


rownum = 2

Do Until sht2.Cells(rownum, 1) = ""
    If sht2.Cells(rownum, 1) Like "v*" Then
        Rows(rownum).Insert
        Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
        Rows(Lastrow2).Copy Rows(rownum)
        Rows(Lastrow2).ClearContents
        exit sub
    End If
rownum = rownum + 1
Loop

End Sub

 

[santa12345]

Hi. the only issue is the sort... the parts can be all over the place.
Can we add a sort after each sub part section.....?

 

[santa12345]

OH !!! I think what you last sent me worked !!! I will add a few more scenarios and keep testing...but I think you got it.
This is wonderful !!!! Thank you!

 

[santa12345]

Is there a way to remove blanks? Meaning if one of the columns doesn't have data populated in every cell, can the blanks - not be counted?
Currently, using the vb above, I get a row with blanks and a count.

 

[santa12345]

Here is the summary tab output.

 

[mrshl9898]

Try:

Sub CreateSummary()

Dim sht As Worksheet
Dim Lastrow As Long
Dim sht2 As Worksheet
Dim Lastrow2 As Long
Dim rownum As Long

Sheets.Add.Name = "Summary"

Set sht = Sheets("Order")
Set sht2 = Sheets("Summary")

sht2.Range("A1") = "Sub Part"
sht2.Range("B1") = "Total Qty"
Lastrow = sht.Cells(sht.Rows.Count, "D").End(xlUp).Row
sht.Range("D2:D" & Lastrow).Copy sht2.Range("A2")
Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
Lastrow = sht.Cells(sht.Rows.Count, "E").End(xlUp).Row
sht.Range("E2:E" & Lastrow).Copy sht2.Range("A" & Lastrow2 + 1)
Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
Lastrow = sht.Cells(sht.Rows.Count, "F").End(xlUp).Row
sht.Range("F2:F" & Lastrow).Copy sht2.Range("A" & Lastrow2 + 1)
Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
Lastrow = sht.Cells(sht.Rows.Count, "G").End(xlUp).Row
sht.Range("G2:G" & Lastrow).Copy sht2.Range("A" & Lastrow2 + 1)
Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row

sht2.Range("A1:A" & Lastrow2).RemoveDuplicates Columns:=Array(1), Header:=xlYes
sht2.Range("B2").FormulaR1C1 = _
    "=SUMIFS(Order!C,Order!C[2],RC[-1])+SUMIFS(Order!C,Order!C[3],RC[-1])+SUMIFS(Order!C,Order!C[4],RC[-1])+SUMIFS(Order!C,Order!C[5],RC[-1])"
Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
sht2.Range("B2").Copy sht2.Range("B2:B" & Lastrow2)

sht2.Range("A1:B" & Lastrow2).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes


rownum = 2

Do Until sht2.Cells(rownum, 1) = ""
    If sht2.Cells(rownum, 1) Like "v*" Then
        Rows(rownum).Insert
        Lastrow2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
        Rows(Lastrow2).Copy Rows(rownum)
        Rows(Lastrow2).ClearContents
        Exit Sub
    End If
rownum = rownum + 1
Loop

End Sub

 

[santa12345]

Hello and thank you for the reply!
I get the following error.

Here is the line it errors out on...

Thank you once again!

 

[Marc L]

Hi,​

​

just add the same worksheet reference to the second range …​

 

[santa12345]

Sorry more one note.
If I comment out the sort error line item above... the macro runs all the way thru w/o errors.
but then I get the following in my output.

 

[santa12345]

Thank you for the reply.
The sort error is fixed.
The only issue I have is ...if any of the rows in columns D-G... are blank. I will get the following in the summary tab.
Line 1 which is the header is good.
Lines 2-29 are summarized and calculated (summed up) correctly.
I just get the line item of 31 showing as blank with a 0.