Consulting

Results 1 to 4 of 4

Thread: Code Optimization: Running too slow

  1. #1
    VBAX Regular
    Joined
    Sep 2008
    Posts
    29
    Location

    Code Optimization: Running too slow

    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

  2. #2
    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

    [vba]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"), 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
    [/vba]

    [vba]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

    [/vba]
    -------------------------------------------------
    The more details you give, the easier it is to understand your question. Don't save the effort, tell us twice rather than not at all. The amount of info you give strongly influences the quality of answer, and also how fast you get it.

  3. #3
    An alternative to Sub Change_Part_Numbers:

    [vba]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
    [/vba]
    -------------------------------------------------
    The more details you give, the easier it is to understand your question. Don't save the effort, tell us twice rather than not at all. The amount of info you give strongly influences the quality of answer, and also how fast you get it.

  4. #4
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,443
    Location
    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.
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •