Code Optimization: Running too slow

[suriyahi]

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!!!:banghead:



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

[JimmyTheHand]

I'm giving two alternatives to Sub Setup_Pricing_Detail_Sheet.
The 2nd one is a more compact version of the 1st, and it may or may not work, depending on your spreadsheet structure.

Both pieces of code below use the rightmost (IV) column to create a temporary set of data. The formulas created in Column IV will result

1 where the filtering condition is true
"x"where the filtering condition is false

Then the 1-s are selected and their rows deleted in one single step. No looping is required.
Warning: If your spreadsheet is so large that it uses Column IV, then the code will destroy the data in there.
Also, I haven't tested any of this. If you could provide some sample data, I'd be more confident in giving recommendations.

Jimmy


Sub Setup_Pricing_Detail_Sheet_Version1()
Dim Rng As Range, DelRange As Range
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)
Set Rng = Range(Rng(13), Rng(Rng.Cells.Count))
With Intersect(Rng.EntireRow, Range("IV:IV"))
.Formula = "=IF(TRIM(SUBSTITUTE(" & Rng(1).Address(False, False) & ",CHAR(160),CHAR(32)))="""",1,""x"")"
Set DelRange = .SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow
If Not DelRange Is Nothing Then DelRange.Delete
End With
' *Delete rows in Col I that have "0" in them
Set Rng = Intersect(Range("I:I"), ActiveSheet.UsedRange)
Set Rng = Range(Rng(13), Rng(Rng.Cells.Count))
With Intersect(Rng.EntireRow, Range("IV:IV"))
.Formula = "=IF(TRIM(SUBSTITUTE(" & Rng(1).Address(False, False) & ",CHAR(160),CHAR(32)))=""0"",1,""x"")"
Set DelRange = .SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow
If Not DelRange Is Nothing Then DelRange.Delete
End With
' *Delete rows in Col D that are blank (ie warranty lines)
Set Rng = Intersect(Range("D:D"), ActiveSheet.UsedRange)
Set Rng = Range(Rng(13), Rng(Rng.Cells.Count))
With Intersect(Rng.EntireRow, Range("IV:IV"))
.Formula = "=IF(TRIM(SUBSTITUTE(" & Rng(1).Address(False, False) & ",CHAR(160),CHAR(32)))="""",1,""x"")"
Set DelRange = .SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow
If Not DelRange Is Nothing Then DelRange.Delete
End With
Range("IV:IV").ClearContents
Application.Calculation = xlCalculationAutomatic
End Sub


And....


Sub Setup_Pricing_Detail_Sheet_Version2()
Dim Rng As Range, DelRange As Range
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
Set Rng = Intersect(Range("A:A"), ActiveSheet.UsedRange)
Set Rng = Range(Rng(13), Rng(Rng.Cells.Count))
With Intersect(Rng.EntireRow, Range("IV:IV"))
' *Delete rows in Col F that are blank
.Formula = "=IF(TRIM(SUBSTITUTE(" & Rng(1).Offset(, 5).Address(False, False) & ",CHAR(160),CHAR(32)))="""",1,""x"")"
Set DelRange = .SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow
If Not DelRange Is Nothing Then DelRange.Delete
' *Delete rows in Col I that have "0" in them
.Formula = "=IF(TRIM(SUBSTITUTE(" & Rng(1).Offset(, 8).Address(False, False) & ",CHAR(160),CHAR(32)))=""0"",1,""x"")"
Set DelRange = .SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow
If Not DelRange Is Nothing Then DelRange.Delete
' *Delete rows in Col D that are blank (ie warranty lines)
.Formula = "=IF(TRIM(SUBSTITUTE(" & Rng(1).Offset(, 3).Address(False, False) & ",CHAR(160),CHAR(32)))="""",1,""x"")"
Set DelRange = .SpecialCells(xlCellTypeFormulas, xlNumbers).EntireRow
If Not DelRange Is Nothing Then DelRange.Delete
End With
Range("IV:IV").ClearContents
Application.Calculation = xlCalculationAutomatic
End Sub

[JimmyTheHand]

An alternative to Sub Change_Part_Numbers:


Sub Change_Part_Numbers_mod()
Dim TotalParts As Range
Dim Lastrow As Long
Lastrow = Range("F14").End(xlDown).Row
Set TotalParts = Range("F14:F" & Lastrow)
With TotalParts
.Replace What:="39M5785", Replacement:="46C7418", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=True
.Replace What:="LTA-00040-IHG", Replacement:="LTA-00040"
.Replace What:="12205112", Replacement:="14344822"
.Replace What:="12107484", Replacement:="14174504"
.Replace What:="3400-32", Replacement:="X3400-V9"
.Replace What:="6073-ADU", Replacement:="6234-A1U"
.Replace What:="73P4984", Replacement:="45J5435"
.Replace What:="6073FN_V2", Replacement:="6234A1U_FN"
.Replace What:="6073FO_V2", Replacement:="6234A1U_FO"
.Replace What:="1532N", Replacement:="30G0100"
.Replace What:="39V0214", Replacement:="30G0802"
.Replace What:="WS-C2950-24", Replacement:="WS-C2960-24TT-L"
.Replace What:="SUA1500RM2U", Replacement:="SUA1500R2X122"
End With
done:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

[Bob Phillips]

I would add some timing code before each loop and see which ones take the most time, then you can concentrate on the big offenders.