Sort and Combine

[kdreyer]

I have a material list in excel that has some of the same material located in
several spots on a list. Presently we run a Macro that creates a new tab
that Sorts them all together but leaves each item showing. Is there anyway
to set up the macro to add them all together on one line and sum the qty of
each separate item.

This is the current Macro:

Rows("1:1000").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "sheet 1"
Range("A1").Select
'

Sheets.Add
Columns("D").Select
Selection.ColumnWidth = 40
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With
Range("A1").Select
ActiveCell.FormulaR1C1 = "='sheet 1'!RC"

Range("B1").Select
ActiveCell.FormulaR1C1 = "=IF(ISBLANK('sheet 1'!RC),"""",'sheet 1'!RC)"

Range("C1").Select
ActiveCell.FormulaR1C1 = "=IF(ISBLANK('sheet 1'!RC),"""",'sheet 1'!RC)"

Range("D1").Select
ActiveCell.FormulaR1C1 = _
"=IF('sheet 1'!RC[10]=""Shipped"",""ZZZZZZZ"",)& IF(ISBLANK('sheet
1'!RC[-3]),""ZZZZZZZ"",)&IF(ISTEXT('sheet 1'!RC[-3]),""ZZZZZZZZ"",)&'sheet
1'!RC&'sheet 1'!RC[1]&'sheet 1'!RC[2]&'sheet 1'!RC[3]&'sheet
1'!RC[4]&'sheet 1'!RC[5]&'sheet 1'!RC[6]&'sheet 1'!RC[7]&'sheet
1'!RC[8]&'sheet 1'!RC[9]&IF(ISBLANK('sheet 1'!R[1]C),,(IF(ISBLANK('sheet
1'!R[1]C[-3]),'sheet 1'!R[1]C&(IF(ISBLANK('sheet 1'!R[2]C[-3]),'sheet
1'!R[2]C&(IF(ISBLANK('sheet 1'!R[3]C[-3]),'sheet
1'!R[3]C&(IF(ISBLANK('sheet 1'!R[4]C[-3]),'sheet
1'!R[4]C&(IF(ISBLANK('sheet 1'!R[5]C[-3]),'sheet
1'!R[5]C&(IF(ISBLANK('sheet 1'!R[6]C[-3]),'sheet
1'!R[6]C,)),)),)),)),)),)))"

Range("E1").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISBLANK('sheet 1'!R[1]C[-1]),,(IF(ISBLANK('sheet
1'!R[1]C[-4]),(IF(ISBLANK('sheet 1'!R[2]C[-4]),(IF(ISBLANK('sheet
1'!R[3]C[-4]),(IF(ISBLANK('sheet 1'!R[4]C[-4]),(IF(ISBLANK('sheet
1'!R[5]C[-4]),(IF(ISBLANK('sheet 1'!R[6]C[-4]),""MAXED
OUT"",)),)),)),)),)),)))"

Range("F1").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISBLANK('sheet 1'!R[6]C[-2]),,(IF(ISBLANK('sheet
1'!R[7]C[-5]),'sheet 1'!R[7]C[-2]&(IF(ISBLANK('sheet 1'!R[8]C[-5]),'sheet
1'!R[8]C[-2]&(IF(ISBLANK('sheet 1'!R[9]C[-5]),'sheet
1'!R[9]C[-2]&(IF(ISBLANK('sheet 1'!R[10]C[-5]),'sheet
1'!R[10]C[-2]&(IF(ISBLANK('sheet 1'!R[11]C[-5]),'sheet
1'!R[11]C[-2]&(IF(ISBLANK('sheet 1'!R[12]C[-5]),'sheet
1'!R[12]C[-2],)),)),)),)),)),)))"

Range("G1").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]=""MAXED OUT"",RC[-3]&""
""&RC[-1],RC[-3])"

Rows("1:1").Select
Selection.AutoFill Destination:=Rows("1:1000"), Type:=xlFillDefault



Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False
Range("D1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=RC[3]"
Range("D1").Select
Selection.AutoFill Destination:=Range("D11000"), Type:=xlFillDefault

Range("D11000").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False

Columns("E").Select
Selection.Delete Shift:=xlLeft

Range("E1").Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With

Selection.AutoFill Destination:=Range("E1:E1000"), Type:=xlFillDefault


'this sorts the data alphabetically by column D
Cells.Select
Selection.Sort Key1:=Range("D1"), Order1:=xlAscending, Header:=xlGuess,
_
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

'This finds all the entries that have ZZZZZZ
Range("A1").Select
Cells.Find(What:="ZZZZ", After:=ActiveCell, LookIn:=xlFormulas,
LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:= _
False).Activate

'This deletes all the entries that have ZZZZZZ
Rows(Selection.Row & ":1050").Select
Selection.Delete Shift:=xlUp
Range("A1").Select

'This adds the title
Rows("1:9").Select
Selection.Insert Shift:=xlDown
Range("D1").Select
ActiveCell.FormulaR1C1 = "SHIPPING SUMMARY"
With Selection
.HorizontalAlignment = xlCenter
End With
Selection.Font.Bold = True

Range("B2").Select
ActiveCell.FormulaR1C1 = "='sheet 1'!R[5]C[0]"
Range("D2").Select

ActiveCell.FormulaR1C1 = "='sheet 1'!R[5]C[-1]"
Rows("2:2").Select
Selection.AutoFill Destination:=Rows("2:6"), Type:=xlFillDefault

'this pastes the header value only
Rows("2:6").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=
_
False, Transpose:=False

Range("D24").Select
Selection.Font.Bold = True

Columns("A:A").ColumnWidth = 8.43
Columns("B:B").ColumnWidth = 8.57
Columns("C:C").ColumnWidth = 8.43
Columns("D").ColumnWidth = 51.57
Columns("E:E").ColumnWidth = 9.86


Range("A9").Select
ActiveCell.FormulaR1C1 = "QTY"
Range("B9").Select
ActiveCell.FormulaR1C1 = "Units"
Range("C9").Select
ActiveCell.FormulaR1C1 = "S.D. NO"
Range("D9").Select
ActiveCell.FormulaR1C1 = "DESCRIPTION"
Range("E9").Select
ActiveCell.FormulaR1C1 = "SHIPPED"

'this adds the double line under the headings
Range("A9:E9").Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With


'this formats the printing
With ActiveSheet.PageSetup
.PrintTitleRows = "$9:$9"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.CenterFooter = "Page &P of &N"
End With

'delete worksheet 1 and rename worksheet 2
Sheets("sheet 1").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "SUMMARY"