Djblois
06-29-2006, 09:08 AM
Can anyone help me by shrinking this code and speeding it up. I am looking into adding much more to it and when it deals with large files it takes forever.
MyInput = InputBox("Version 1.2:What do you want to name the File?")
ActiveWorkbook.SaveAs Filename:= _
"H:\@temp\Daniel B\Current Projects\" & MyInput
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set WB = ActiveWorkbook
'Dim test As Boolean, x As Long, lastrow As Long, col As Long
'Dim FillRange As Range
'Range("A1").Select
'col = ActiveCell.Column
'lastrow = Cells(65536, col).End(xlUp).Row
'Sort
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Sort _
Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
'Delete extra
Columns("A:A").Find(What:="AT", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(-1, 0).Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlUp)).EntireRow.Delete
'Create Customer tab
Columns("A:A").Find(What:="Customer:", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Cut
If Sheets.Count = 1 Then
Sheets.Add
Else: Sheets("Sheet2").Activate
End If
Range("A1").Select
ActiveSheet.Paste
'Remove ) from Data
Columns("A:B").Replace What:=")", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Create Product tab
Columns("A:A").Find(What:="Product:", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=last, MatchCase:= _
False, SearchFormat:=False).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Cut
If Sheets.Count = 2 Then
Sheets.Add
Else: Sheets("Sheet3").Activate
End If
Range("A1").Select
ActiveSheet.Paste
'Delete any rows that start with "Date" in product tab
Columns("A:A").Find(What:="Product", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:= _
False).Offset(1, 0).Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete
'Create Item# Column in product tab
Range("B1").Select
ActiveCell.FormulaR1C1 = "=Mid(RC[-1],10,6)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Create Products Column in product tab
Range("C1").Select
ActiveCell.FormulaR1C1 = "=PROPER(Trim(MID(RC[-2],18,80)))"
Selection.Copy
ActiveCell.Offset(0, -2).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 2).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
Columns("A:A").Delete Shift:=xlToLeft
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Delete any rows that start with "Profile" in Cust tab
Sheets("Sheet2").Select
Columns("B:C").Delete
Range("A1").Select
Selection.End(xlDown).Select
Cells.Find(What:="Customer", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:= _
False).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete
'Create Cust# Column in customer tab
Range("B1").Select
ActiveCell.FormulaR1C1 = "=Mid(RC[-1],11,4)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Create Customer Column in customer tab
Range("C1").Select
ActiveCell.FormulaR1C1 = "=PROPER(Trim(MID(RC[-2],17,50)))"
Selection.Copy
ActiveCell.Offset(0, -2).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 2).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
Columns("A:A").Delete Shift:=xlToLeft
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Sheets("Sheet1").Select
'Clean Bottem of Database
DeleteAtalanta
'Delete Columns
Columns("C:C").Delete Shift:=xlToLeft
Columns("F:F").Delete Shift:=xlToLeft
Columns("P:V").Delete Shift:=xlToLeft
'Open Atalanta Codes workbook
Workbooks.Open Filename:="H:\@temp\Daniel B\Reference\Atalanta Codes.xls"
WB.Activate
'FinalRow = Range("A65536").End(x1Up).Row
'Fix Invoice# (A)
Rows("1:1").Insert Shift:=xlDown
Range("A1").FormulaR1C1 = "Invoice#"
'Fix Date (B)
Range("B1").FormulaR1C1 = "Date"
With Columns("B:B")
.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 3), TrailingMinusNumbers:=True
.NumberFormat = "mm/dd/yy;@"
End With
'Add Warehouses (C)
Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("D:D").Insert Shift:=xlToRight
Range("D1").FormulaR1C1 = "Whse"
Range("D2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[Atalanta Codes.xls]Whses'!C1:C8,2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
Columns("C:C").Delete
'Fix Cust# (D)
Range("D1").FormulaR1C1 = "Cust#"
Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Add Customers (E)
Columns("E:E").Insert Shift:=xlToRight
Range("E1").FormulaR1C1 = "Customer"
Range("E2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Sheet2!C[-5]:C[-4],2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Fix Sls# (F)
Range("F1").FormulaR1C1 = "Sls#"
Columns("F:F").TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Add SlsPrsn (G)
Columns("G:G").Insert Shift:=xlToRight
Range("G1").FormulaR1C1 = "SlsPrsn"
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[Atalanta Codes.xls]SlsPrsn'!C1:C8,2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Fix Item# (H)
Range("H1").FormulaR1C1 = "Item#"
With Range("H:H")
.TextToColumns Destination:=Range("H1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "00-0000"
End With
'Add Product (I)
Columns("I:I").Insert Shift:=xlToRight
Range("I1").FormulaR1C1 = "Product"
Range("I2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Sheet3!C[-9]:C[-8],2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -7).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 7).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Add Dept (J)
Columns("J:J").Insert Shift:=xlToRight
Range("J1").FormulaR1C1 = "Dept"
Range("J2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-2],'[Atalanta Codes.xls]Products'!C1:C12,3,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -8).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 8).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Fix Qty (K)
Range("K1").FormulaR1C1 = "Qty"
With Columns("K:K")
.TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Fix Units (L)
Range("L1").FormulaR1C1 = "Units"
With Columns("L:L")
.TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Style = "Comma"
End With
'Fix Price (M)
Range("M1").FormulaR1C1 = "Price"
With Columns("M:M")
.TextToColumns Destination:=Range("M1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Style = "Comma"
End With
'Add Delivery (N)
Range("N1").FormulaR1C1 = "D"
Range("M2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Replace What:="D", Replacement:="Del", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Fix Amt (O)
Range("O1").FormulaR1C1 = "Amt"
With Columns("O:O")
.TextToColumns Destination:=Range("O1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Fix Equivalant (P)
Range("P1").FormulaR1C1 = "Equivalant"
With Columns("P:P")
.TextToColumns Destination:=Range("P1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Fix Ext-Cost (Q)
Range("Q1").FormulaR1C1 = "Ext-Cost"
With Columns("Q:Q")
.TextToColumns Destination:=Range("Q1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Fix Unit-Cost (R)
Range("R1").FormulaR1C1 = "Unit-Cost"
With Columns("R:R")
.TextToColumns Destination:=Range("R1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Fix Profit (S)
Range("S1").FormulaR1C1 = "Profit"
With Columns("S:S")
.TextToColumns Destination:=Range("S1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Add Percentage to End (T)
Range("T1").FormulaR1C1 = "%"
Range("T2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-5]=0,""No Sale"",RC[-1]/RC[-5])"
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _
Formula1:="0"
With Selection.FormatConditions(1)
.Font.Bold = True
.Interior.ColorIndex = 44
End With
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""No Sale"""
With Selection.FormatConditions(2)
.Font.Bold = True
.Interior.ColorIndex = 6
End With
Selection.Copy
ActiveCell.Offset(0, -19).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 19).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
Columns("T:T").NumberFormat = "0.00%"
'Close Atlanta Codes workbook and delete product and customer lists
Windows("Atalanta Codes.xls").Close
ActiveSheet.Name = "Detail"
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
'Set Print Heading
With Range("A1:T1")
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
End With
With ActiveSheet.PageSetup
.LeftHeader = "&""Arial,Bold""&12Atalanta"
.CenterHeader = "&""Arial,Bold""&14&A"
.RightHeader = "&""Arial,Bold""&12Sorted by"
.LeftFooter = "&""Arial,Bold""&D &T Dan Blois"
.CenterFooter = "&""Arial,Bold""&F"
.RightFooter = "&""Arial,Bold""Page &P of &N"
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.9)
.BottomMargin = Application.InchesToPoints(0.6)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintGridlines = True
.CenterHorizontally = True
.FitToPagesWide = 1
.PrintTitleRows = "$1:$1"
End With
'Hide Columns
Columns("F:F").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
'Sort By Customer Then Product Then Date
Range("A1:T2243").Sort Key1:=Range("E2"), Order1:=xlAscending, Key2:= _
Range("I2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlDescending _
, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal
'Freeze Row 1
Range("A2").Select
ActiveWindow.FreezePanes = True
'Add Invoices Tab
Range("A:S").Select
Selection.Copy
Sheets.Add.Name = "By Invoice"
ActiveSheet.Paste
'Add WareHouse Tab
Sheets.Add.Name = "By Warehouse"
ActiveSheet.Paste
'Add Customer Tab
Sheets.Add.Name = "By Customer"
ActiveSheet.Paste
'Add SalesPerson Tab
Sheets.Add.Name = "By SalesPerson"
ActiveSheet.Paste
'Add Product Tab
Sheets.Add.Name = "By Product"
ActiveSheet.Paste
'Add subtotals to Invoices tab
Sheets("By Invoice").Activate
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(11, 12, 15, 17 _
, 18, 19), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:S").EntireColumn.AutoFit
Columns("B:J").EntireColumn.Hidden = True
Columns("M:N").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
Columns("A:A").Replace What:="Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
ActiveWindow.FreezePanes = True
'Add subtotals to WareHouse tab
Sheets("By WareHouse").Activate
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(11, 12, 15, 17 _
, 18, 19), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:S").EntireColumn.AutoFit
Columns("A:B").EntireColumn.Hidden = True
Columns("D:J").EntireColumn.Hidden = True
Columns("M:N").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
Columns("C:C").Replace What:="Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
ActiveWindow.FreezePanes = True
'Add subtotals to Customer tab
Sheets("By Customer").Activate
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=5, Function:=xlSum, TotalList:=Array(11, 12, 15, 17 _
, 18, 19), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:S").EntireColumn.AutoFit
Columns("A:D").EntireColumn.Hidden = True
Columns("F:J").EntireColumn.Hidden = True
Columns("M:N").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
Columns("E:E").Replace What:="Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
ActiveWindow.FreezePanes = True
'Add subtotals to SalesPerson tab
Sheets("By SalesPerson").Activate
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=7, Function:=xlSum, TotalList:=Array(11, 12, 15, 17 _
, 18, 19), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:S").EntireColumn.AutoFit
Columns("A:F").EntireColumn.Hidden = True
Columns("H:J").EntireColumn.Hidden = True
Columns("M:N").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
Columns("G:G").Replace What:="Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
ActiveWindow.FreezePanes = True
'Add subtotals to Product tab
Sheets("By Product").Activate
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("I2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=9, Function:=xlSum, TotalList:=Array(11, 12, 15, 17 _
, 18, 19), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:S").EntireColumn.AutoFit
Columns("A:H").EntireColumn.Hidden = True
Columns("J:J").EntireColumn.Hidden = True
Columns("M:N").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
Columns("I:I").Replace What:="Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
ActiveWindow.FreezePanes = True
'End
Sheets("Detail").Activate
ActiveWorkbook.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("A2").Select
End Sub
MyInput = InputBox("Version 1.2:What do you want to name the File?")
ActiveWorkbook.SaveAs Filename:= _
"H:\@temp\Daniel B\Current Projects\" & MyInput
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set WB = ActiveWorkbook
'Dim test As Boolean, x As Long, lastrow As Long, col As Long
'Dim FillRange As Range
'Range("A1").Select
'col = ActiveCell.Column
'lastrow = Cells(65536, col).End(xlUp).Row
'Sort
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Sort _
Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers
'Delete extra
Columns("A:A").Find(What:="AT", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Offset(-1, 0).Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlUp)).EntireRow.Delete
'Create Customer tab
Columns("A:A").Find(What:="Customer:", After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Cut
If Sheets.Count = 1 Then
Sheets.Add
Else: Sheets("Sheet2").Activate
End If
Range("A1").Select
ActiveSheet.Paste
'Remove ) from Data
Columns("A:B").Replace What:=")", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Create Product tab
Columns("A:A").Find(What:="Product:", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=last, MatchCase:= _
False, SearchFormat:=False).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Cut
If Sheets.Count = 2 Then
Sheets.Add
Else: Sheets("Sheet3").Activate
End If
Range("A1").Select
ActiveSheet.Paste
'Delete any rows that start with "Date" in product tab
Columns("A:A").Find(What:="Product", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:= _
False).Offset(1, 0).Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete
'Create Item# Column in product tab
Range("B1").Select
ActiveCell.FormulaR1C1 = "=Mid(RC[-1],10,6)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Create Products Column in product tab
Range("C1").Select
ActiveCell.FormulaR1C1 = "=PROPER(Trim(MID(RC[-2],18,80)))"
Selection.Copy
ActiveCell.Offset(0, -2).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 2).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
Columns("A:A").Delete Shift:=xlToLeft
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Delete any rows that start with "Profile" in Cust tab
Sheets("Sheet2").Select
Columns("B:C").Delete
Range("A1").Select
Selection.End(xlDown).Select
Cells.Find(What:="Customer", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:= _
False).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete
'Create Cust# Column in customer tab
Range("B1").Select
ActiveCell.FormulaR1C1 = "=Mid(RC[-1],11,4)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Create Customer Column in customer tab
Range("C1").Select
ActiveCell.FormulaR1C1 = "=PROPER(Trim(MID(RC[-2],17,50)))"
Selection.Copy
ActiveCell.Offset(0, -2).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 2).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
Columns("A:A").Delete Shift:=xlToLeft
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Sheets("Sheet1").Select
'Clean Bottem of Database
DeleteAtalanta
'Delete Columns
Columns("C:C").Delete Shift:=xlToLeft
Columns("F:F").Delete Shift:=xlToLeft
Columns("P:V").Delete Shift:=xlToLeft
'Open Atalanta Codes workbook
Workbooks.Open Filename:="H:\@temp\Daniel B\Reference\Atalanta Codes.xls"
WB.Activate
'FinalRow = Range("A65536").End(x1Up).Row
'Fix Invoice# (A)
Rows("1:1").Insert Shift:=xlDown
Range("A1").FormulaR1C1 = "Invoice#"
'Fix Date (B)
Range("B1").FormulaR1C1 = "Date"
With Columns("B:B")
.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 3), TrailingMinusNumbers:=True
.NumberFormat = "mm/dd/yy;@"
End With
'Add Warehouses (C)
Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("D:D").Insert Shift:=xlToRight
Range("D1").FormulaR1C1 = "Whse"
Range("D2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[Atalanta Codes.xls]Whses'!C1:C8,2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
Columns("C:C").Delete
'Fix Cust# (D)
Range("D1").FormulaR1C1 = "Cust#"
Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Add Customers (E)
Columns("E:E").Insert Shift:=xlToRight
Range("E1").FormulaR1C1 = "Customer"
Range("E2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Sheet2!C[-5]:C[-4],2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Fix Sls# (F)
Range("F1").FormulaR1C1 = "Sls#"
Columns("F:F").TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'Add SlsPrsn (G)
Columns("G:G").Insert Shift:=xlToRight
Range("G1").FormulaR1C1 = "SlsPrsn"
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[Atalanta Codes.xls]SlsPrsn'!C1:C8,2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Fix Item# (H)
Range("H1").FormulaR1C1 = "Item#"
With Range("H:H")
.TextToColumns Destination:=Range("H1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "00-0000"
End With
'Add Product (I)
Columns("I:I").Insert Shift:=xlToRight
Range("I1").FormulaR1C1 = "Product"
Range("I2").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],Sheet3!C[-9]:C[-8],2,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -7).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 7).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Add Dept (J)
Columns("J:J").Insert Shift:=xlToRight
Range("J1").FormulaR1C1 = "Dept"
Range("J2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-2],'[Atalanta Codes.xls]Products'!C1:C12,3,FALSE)"
Selection.Copy
ActiveCell.Offset(0, -8).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 8).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
'Fix Qty (K)
Range("K1").FormulaR1C1 = "Qty"
With Columns("K:K")
.TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Fix Units (L)
Range("L1").FormulaR1C1 = "Units"
With Columns("L:L")
.TextToColumns Destination:=Range("L1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Style = "Comma"
End With
'Fix Price (M)
Range("M1").FormulaR1C1 = "Price"
With Columns("M:M")
.TextToColumns Destination:=Range("M1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Style = "Comma"
End With
'Add Delivery (N)
Range("N1").FormulaR1C1 = "D"
Range("M2").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
Selection.Replace What:="D", Replacement:="Del", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Fix Amt (O)
Range("O1").FormulaR1C1 = "Amt"
With Columns("O:O")
.TextToColumns Destination:=Range("O1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Fix Equivalant (P)
Range("P1").FormulaR1C1 = "Equivalant"
With Columns("P:P")
.TextToColumns Destination:=Range("P1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Fix Ext-Cost (Q)
Range("Q1").FormulaR1C1 = "Ext-Cost"
With Columns("Q:Q")
.TextToColumns Destination:=Range("Q1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Fix Unit-Cost (R)
Range("R1").FormulaR1C1 = "Unit-Cost"
With Columns("R:R")
.TextToColumns Destination:=Range("R1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Fix Profit (S)
Range("S1").FormulaR1C1 = "Profit"
With Columns("S:S")
.TextToColumns Destination:=Range("S1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.NumberFormat = "#,##0"
End With
'Add Percentage to End (T)
Range("T1").FormulaR1C1 = "%"
Range("T2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-5]=0,""No Sale"",RC[-1]/RC[-5])"
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, _
Formula1:="0"
With Selection.FormatConditions(1)
.Font.Bold = True
.Interior.ColorIndex = 44
End With
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""No Sale"""
With Selection.FormatConditions(2)
.Font.Bold = True
.Interior.ColorIndex = 6
End With
Selection.Copy
ActiveCell.Offset(0, -19).Range("A1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 19).Range("A1").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
With Selection
.Copy
Selection.PasteSpecial Paste:=xlValues
End With
Columns("T:T").NumberFormat = "0.00%"
'Close Atlanta Codes workbook and delete product and customer lists
Windows("Atalanta Codes.xls").Close
ActiveSheet.Name = "Detail"
Sheets("Sheet2").Delete
Sheets("Sheet3").Delete
'Set Print Heading
With Range("A1:T1")
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
End With
With ActiveSheet.PageSetup
.LeftHeader = "&""Arial,Bold""&12Atalanta"
.CenterHeader = "&""Arial,Bold""&14&A"
.RightHeader = "&""Arial,Bold""&12Sorted by"
.LeftFooter = "&""Arial,Bold""&D &T Dan Blois"
.CenterFooter = "&""Arial,Bold""&F"
.RightFooter = "&""Arial,Bold""Page &P of &N"
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.9)
.BottomMargin = Application.InchesToPoints(0.6)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintGridlines = True
.CenterHorizontally = True
.FitToPagesWide = 1
.PrintTitleRows = "$1:$1"
End With
'Hide Columns
Columns("F:F").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
'Sort By Customer Then Product Then Date
Range("A1:T2243").Sort Key1:=Range("E2"), Order1:=xlAscending, Key2:= _
Range("I2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlDescending _
, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal
'Freeze Row 1
Range("A2").Select
ActiveWindow.FreezePanes = True
'Add Invoices Tab
Range("A:S").Select
Selection.Copy
Sheets.Add.Name = "By Invoice"
ActiveSheet.Paste
'Add WareHouse Tab
Sheets.Add.Name = "By Warehouse"
ActiveSheet.Paste
'Add Customer Tab
Sheets.Add.Name = "By Customer"
ActiveSheet.Paste
'Add SalesPerson Tab
Sheets.Add.Name = "By SalesPerson"
ActiveSheet.Paste
'Add Product Tab
Sheets.Add.Name = "By Product"
ActiveSheet.Paste
'Add subtotals to Invoices tab
Sheets("By Invoice").Activate
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(11, 12, 15, 17 _
, 18, 19), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:S").EntireColumn.AutoFit
Columns("B:J").EntireColumn.Hidden = True
Columns("M:N").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
Columns("A:A").Replace What:="Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
ActiveWindow.FreezePanes = True
'Add subtotals to WareHouse tab
Sheets("By WareHouse").Activate
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(11, 12, 15, 17 _
, 18, 19), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:S").EntireColumn.AutoFit
Columns("A:B").EntireColumn.Hidden = True
Columns("D:J").EntireColumn.Hidden = True
Columns("M:N").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
Columns("C:C").Replace What:="Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
ActiveWindow.FreezePanes = True
'Add subtotals to Customer tab
Sheets("By Customer").Activate
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=5, Function:=xlSum, TotalList:=Array(11, 12, 15, 17 _
, 18, 19), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:S").EntireColumn.AutoFit
Columns("A:D").EntireColumn.Hidden = True
Columns("F:J").EntireColumn.Hidden = True
Columns("M:N").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
Columns("E:E").Replace What:="Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
ActiveWindow.FreezePanes = True
'Add subtotals to SalesPerson tab
Sheets("By SalesPerson").Activate
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("G2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=7, Function:=xlSum, TotalList:=Array(11, 12, 15, 17 _
, 18, 19), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:S").EntireColumn.AutoFit
Columns("A:F").EntireColumn.Hidden = True
Columns("H:J").EntireColumn.Hidden = True
Columns("M:N").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
Columns("G:G").Replace What:="Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
ActiveWindow.FreezePanes = True
'Add subtotals to Product tab
Sheets("By Product").Activate
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Sort Key1:=Range("I2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=9, Function:=xlSum, TotalList:=Array(11, 12, 15, 17 _
, 18, 19), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
ActiveSheet.Outline.ShowLevels RowLevels:=2
Columns("A:S").EntireColumn.AutoFit
Columns("A:H").EntireColumn.Hidden = True
Columns("J:J").EntireColumn.Hidden = True
Columns("M:N").EntireColumn.Hidden = True
Columns("P:P").EntireColumn.Hidden = True
Columns("I:I").Replace What:="Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A2").Select
ActiveWindow.FreezePanes = True
'End
Sheets("Detail").Activate
ActiveWorkbook.Save
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("A2").Select
End Sub