Neep help speeding up some code

[Djblois]

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.

[VBA]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").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").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").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
[/VBA]

[ALe]

WOW! I've never seen so many lines!

first of all avoid selection as much as you can

for example
[vba]Range("A:S").Select
Selection.Copy
[/vba] becomes
[vba]Range("A:S").copy[/vba] or [vba]
Range("C1").Select
ActiveCell.FormulaR1C1 = "=PROPER(Trim(MID(RC[-2],18,80)))"
[/vba] becomes
[vba]Range("C1").FormulaR1C1 = "=PROPER(Trim(MID(RC[-2],18,80)))" [/vba]

[compariniaa]

Did you declare your variables (if you're even using any)? If you didn't excel has to figure it out, which slows it down.

[Zack Barresse]

Yeah, I'm not going to translate all that stuff either. I did, however, do a few lines. See if this makes any sense ...

[vba] Dim wb As Workbook, ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim rngFind As Range, MyInput As String

MyInput = InputBox("Version 1.2: What do you want to name the File?")
ActiveWorkbook.SaveAs "H:\@temp\Daniel B\Current Projects\" & MyInput
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
ws.Range("A1", ws.Cells(Rws.ows.Count, 1).End(xlUp)).Sort Key1:=ws.Range("A1"), Order1:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
Set rngFind = ws.Range("A:A").Find(What:="AT", After:=ws.Range("A1"), LookIn:=xlValues, LookAt:=xlPart).Offset(-1, 0)
ws.Range(rngFind, ws.Range(rngFind, rngFind.End(xlToRight).End(xlUp))).EntireRow.Delete
Set rngFind = ws.Range("A:A").Find(What:="Customer:", After:=ws.Range("A1"), LookIn:=xlValues, LookAt:=xlPart)
ws.Range(rngFind, ws.Cells(ws.Rows.Count, rngFind.Column).End(xlUp)).Cut
If wb.Sheets.Count = 1 Then
Set ws2 = wb.Worksheets.Add
Else
Set ws2 = wb.Sheets(2)
End If
ws2.Range("A1").PasteSpecial xlPasteAll
ws2.Columns("A:B").Replace What:=")", Replacement:="", LookAt:=xlPart
Set rngFind = ws2.Range("A:A").Find(What:="Product:", After:=ws2.Range("A1"), LookIn:=xlValues, LookAt:=xlPart)
ws2.Range(rngFind, ws2.Cells(ws2.Rows.Count, rngFind.Column)).Cut
If wb.Sheets.Count = 2 Then
Set ws3 = wb.Sheets.Add
Else
Set ws3 = Sheets(3)
End If
ws3.Range("A1").PasteSpecial xlPasteAll
ws3.Cells.AutoFilter field:=1, Criteria1:="Date*"
On Error Resume Next
ws3.Range("A2:A" & ws3.Rows.Count).EntireRow.SpecialCells(xlCellTypeVisible).Delete
ws3.AutoFilterMode = False
ws3.Range("B1:B" & ws3.Cells(ws3.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = "=Mid(RC[-1],10,6)"
ws3.Range("B1:B" & ws3.Cells(ws3.Rows.Count, 1).End(xlUp).Row).Value = ws3.Range("B1:B" & ws3.Cells(ws3.Rows.Count, 1).End(xlUp).Row).Value
ws3.Range("C1:C" & ws3.Cells(ws3.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = "=PROPER(Trim(MID(RC[-2],18,80)))"
ws3.Range("C1:CB" & ws3.Cells(ws3.Rows.Count, 1).End(xlUp).Row).Value = ws3.Range("C1:C" & ws3.Cells(ws3.Rows.Count, 1).End(xlUp).Row).Value
ws3.Columns("A:A").Delete Shift:=xlToLeft
ws3.Columns("A:A").TextToColumns Destination:=ws3.Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True
ws2.Range("B:C").Delete
ws2.Cells.AutoFilter field:=1, Criteria1:="Customer*"
On Error Resume Next
ws2.Range("A2:A" & ws2.Rows.Count).EntireRow.SpecialCells(xlCellTypeVisible).Delete
ws2.AutoFilterMode = False
ws2.Range("B1:B" & ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = "=Mid(RC[-1],11,4)"
ws2.Range("B1:B" & ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row).Value = ws2.Range("B1:B" & ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row).Value
ws2.Range("C1:C" & ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = "=PROPER(Trim(MID(RC[-2],17,50)))"
ws2.Range("C1:C" & ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row).Value = ws2.Range("C1:C" & ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row).Value
ws2.Columns("A:A").Delete Shift:=xlToLeft
ws2.Range("A:A").TextToColumns Destination:=ws2.Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Tab:=True, FieldInfo:=Array(1, 1), TrailingMinusNumbers:=True


' 'Clean Bottem of Database
' '// Not Sure what this is..??
' DeleteAtalanta


ws.Range("C:C").Delete Shift:=xlToLeft
ws.Range("F:F").Delete Shift:=xlToLeft
ws.Range("P:V").Delete Shift:=xlToLeft[/vba]

I'm not sure if some of that will work as a lot of it was based on the Selection and/or ActiveCell, which - as mentioned - is not an efficient way to go. You shouldn't have to select anything (generally).

HTH

[mdmackillop]

Heres another "equivalent"
[VBA]
Sub Macro7()
'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
End Sub

Sub Macro7A()
'Create Item# Column in product tab
Dim r As Range
Set r = Range([A1], [A1].End(xlDown))
r.Offset(, 1).FormulaR1C1 = "=Mid(RC[-1],10,6)"
r.Offset(, 1).Copy
[B1].PasteSpecial Paste:=xlValues
Set r = Nothing
End Sub

[/VBA]

I would also suggest that you split your huge sub into a set of smaller routines, and call each in turn. It's much easier to manage and allows you to call the same code from different routines as required.

If your code is running slowly, add a message box between each section to help you pin down the time consuming areas of code.

Regards
MD