Hi Friends -

I have the following codes below and with my test file it used to take about 22 seconds to run it but now after inserting real data in other sheets it is taking almost 7 minutes to run it. And, I wanted to request you to see if there is any tweaking required in my code so that performance gets little better. I apologize for the long code below but I thank you in advance for your help...and time!!! 

Sub Main_Macro()
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
Call Setup_Pricing_Detail_Sheet
Call Delete_Rows_With_Parts_No_Longer_Ordered
Call Change_Part_Numbers
Call Copy_Data_From_Pricing_Detail_to_MAPICS_Order
Sheets("Pricing Detail Dummy").Delete
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub
Sub Setup_Pricing_Detail_Sheet()
Dim rng As Range, ix As Long
Sheets("Pricing Detail").Select
Sheets("Pricing Detail").Copy Before:=Sheets(1)
Sheets("Pricing Detail (2)").Name = "Pricing Detail Dummy"
Cells.EntireRow.Hidden = False
Application.Calculation = xlCalculationManual
 
'*Delete rows in Col F that are blank
Set rng = Intersect(Range("F:F"), ActiveSheet.UsedRange)
  For ix = rng.Count To 13 Step -1
      If Trim(Replace(rng.Item(ix).Text, Chr(160), Chr(32))) = "" Then
        rng.Item(ix).EntireRow.Delete
      End If
  Next
'*Delete rows in Col I that have "0" in them
Set rng = Intersect(Range("I:I"), ActiveSheet.UsedRange)
  For ix = rng.Count To 13 Step -1
      If Trim(Replace(rng.Item(ix).Text, Chr(160), Chr(32))) = "0" Then
        rng.Item(ix).EntireRow.Delete
      End If
  Next
'*Delete rows in Col D that are blank (ie warranty lines)
Set rng = Intersect(Range("D:D"), ActiveSheet.UsedRange)
  For ix = rng.Count To 13 Step -1
      If Trim(Replace(rng.Item(ix).Text, Chr(160), Chr(32))) = "" Then
        rng.Item(ix).EntireRow.Delete
      End If
  Next
 
  Application.Calculation = xlCalculationAutomatic
End Sub
 
Sub Delete_Rows_With_Parts_No_Longer_Ordered()
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim Lrow As Long
    Dim CalcMode As Long
    Dim ViewMode As Long
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With
    With ActiveSheet
        Firstrow = 14
        Lastrow = Range("F14").End(xlDown).Row
        For Lrow = Lastrow To Firstrow Step -1
            With .Cells(Lrow, "F")
                If Not IsError(.Value) Then
                    Select Case .Value
                        Case Is = "32 R2906", "F2L088 -6", "USR5686E", "ACK-595UB", _
                        "14173148", "6073 IFC_V2", "CB -SATD11 - S1", "MK -35 / 525 - HD - BW", _
                        "2811", "1841", "WIC-1T", "CAB -V35MT", "408", "4221530", "CBL0029", _
                        "355022", "????", "90-C5XO-1OR": .EntireRow.Delete
                    End Select
                End If
            End With
        Next Lrow
    End With
    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With
End Sub
'************************
'Part2: Find the parts and replace with new part numbers
Sub Change_Part_Numbers()
Dim c As Range
Dim TotalParts As Range
    Dim Firstrow As Long
    Dim Lastrow As Long
    Dim Lrow As Long
        Firstrow = 14
        Lastrow = Range("F14").End(xlDown).Row
Set TotalParts = Range("F14:F" & Lastrow)
    For Each c In TotalParts
        c = Replace(c, "39M5785", "46C7418")
        c = Replace(c, "LTA-00040-IHG", "LTA-00040")
        c = Replace(c, "12205112", "14344822")
        c = Replace(c, "12107484", "14174504")
        c = Replace(c, "3400-32", "X3400-V9")
        c = Replace(c, "6073-ADU", "6234-A1U")
        c = Replace(c, "73P4984", "45J5435")
        c = Replace(c, "6073FN_V2", "6234A1U_FN")
        c = Replace(c, "6073FO_V2", "6234A1U_FO")
        c = Replace(c, "1532N", "30G0100")
        c = Replace(c, "39V0214", "30G0802")
        c = Replace(c, "WS-C2950-24", "WS-C2960-24TT-L")
        c = Replace(c, "SUA1500RM2U", "SUA1500R2X122")
    Next
 
done:
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
End Sub
Sub Copy_Data_From_Pricing_Detail_to_MAPICS_Order()
    Dim wSht1 As Worksheet, wSht2 As Worksheet
    Dim rng1 As Range
    Dim LastCel As Long, lastAdd1cel As Long, lastPartcel As Long
    Set wSht1 = Sheets("Pricing Detail Dummy")
    Set wSht2 = Sheets("MAPICS Order")
    wSht1.Select
    LastCel = wSht1.Range("F65536").End(xlUp).Row
    Set rng1 = wSht1.Range("F14:F" & LastCel)
    Set rng2 = wSht1.Range("I14:I" & LastCel)
    Application.ScreenUpdating = False
    rng1.Select
    rng1.Copy
    LastCel = wSht2.Range("X65536").End(xlUp).Row
    With wSht2
        .Range("X" & LastCel).Offset(1, 0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    End With
 
    rng2.Select
    rng2.Copy
    LastCel = wSht2.Range("AC65536").End(xlUp).Row
 
    With wSht2
        .Range("AC" & LastCel).Offset(1, 0).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    End With
        wSht2.Select
 
    lastAdd1cel = Range("B65536").End(xlUp).Row
    lastPartcel = Range("X65536").End(xlUp).Row
    Range("B" & lastAdd1cel).AutoFill Destination:=Range("B" & lastAdd1cel & ":B" & lastPartcel)
With Cells.Font
    .Name = "Verdana"
    .Size = 8
End With
Range("A2:AE" & lastPartcel).Borders.LineStyle = xlNone
    Application.ScreenUpdating = True
End Sub