Consulting

Results 1 to 9 of 9

Thread: Speed up VBA code

  1. #1
    VBAX Expert
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    572
    Location

    Speed up VBA code

    Any thoughts on speeding up these macros, I'm not asking for anyone to do it for me just suggestions would be cool

    Sub PaintAllPatterns()    Dim rCell As Range, SWeek As Long, FAddress As String, WeekLoop As Long, WAddress As String
        Dim StartTime As String, pCell As Range, tmpRng As String
        
        'ask if user is sure
        ans = MsgBox("Are you sure" & vbNewLine & vbNewLine & "This will delete all ABS&OT info for the whole year", vbYesNo)
        
        'make sure user wanted to run macro
        If ans = vbNo Then
            Exit Sub
        End If
        
        'get password
        UFPass.Show
        If Sheet3.Range("Q4").Value = "No" Then
            MsgBox "Wrong password" & vbNewLine & vbNewLine & "Will now exit", vbCritical
            Exit Sub
        End If
        
        'unprotect the workbook
        Call Unhide
        Call UnProtector
    
    
        'speed up macro
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .DisplayStatusBar = False
            .EnableEvents = False
        End With
        
        'the ammount of weeks to paint for
        WeekLoop = 52
    
    
        ' clear all from Painted rota
        Sheet2.Select
        Sheet2.Range("K6").Select
        For n = 1 To 52
            Sheet2.Range(ActiveCell, ActiveCell.Offset(294, 7)).ClearContents
            ActiveCell.Offset(, 9).Select
        Next n
        
        ' clear all from ABS&OT
        Sheet2.Range("RT6").Select
        For n = 1 To 52
            Sheet2.Range(ActiveCell, ActiveCell.Offset(294, 6)).ClearContents
            ActiveCell.Offset(, 9).Select
        Next n
    
    
        ' extract names from master patterns
        Sheet1.Range("Q4:Q" & Sheet1.Range("Q" & Rows.Count).End(xlUp).Row).Copy
        Sheet1.Range("AB4").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        ActiveSheet.Range("AB3:AB" & ActiveSheet.Range("AB" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes
        ActiveWorkbook.Worksheets("Master patterns").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Master patterns").Sort.SortFields.Add Key:=Range("AB4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        'sort the driver namse
        With ActiveWorkbook.Worksheets("Master patterns").Sort
            .SetRange Range("AB4:AB" & ActiveSheet.Range("AB" & Rows.Count).End(xlUp).Row)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        'remove headings from the name data
        For Each rCell In Sheet1.Range("AB4:AB" & Sheet1.Range("AB" & Rows.Count).End(xlUp).Row).Cells
            If rCell.Value = "Driver Name" Or rCell.Value = "Fixed" Or rCell.Value = "Rotating" Or rCell.Value = "NA" Then
                rCell.ClearContents
            End If
        Next rCell
        'resort after removing headings
        ActiveWorkbook.Worksheets("Master patterns").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Master patterns").Sort.SortFields.Add Key:=Range("AB4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        With ActiveWorkbook.Worksheets("Master patterns").Sort
            .SetRange Range("AB4:AB" & ActiveSheet.Range("AB" & Rows.Count).End(xlUp).Row)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        'clear drivers from rota page
        Sheet2.Range("A6:A300").ClearContents
        Application.Calculate
        
        'paste new drivers in from master patterns and calculate
        Sheet1.Range("AB4:AB" & Sheet1.Range("AB" & Rows.Count).End(xlUp).Row).Copy
        Sheet2.Range("A6").PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        Application.Calculate
    
    
        'populate the painted rota
        For Each rCell In Sheet2.Range("A6:A" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row).Cells 'loops through driver names in the rota tab
        
            If rCell.Value <> "" Then 'makes sure the cell is not blank
                SWeek = rCell.Offset(, 6).Value 'set the start week
                FAddress = Sheet1.Range("Q5:Q1000").Find(rCell.Value, Sheet1.Range("Q5")).Offset(, -9).Address 'sets the found driver cell as address string
                StartTime = Format(Sheet1.Range("Q5:Q1000").Find(rCell.Value, Sheet1.Range("Q5")).Offset(, 2).Value, "hh:mm") 'sets drivers override time
                
                If Sheet1.Range(FAddress).Offset(, -2).Value = 1 Then 'found a one week rota
                    tmpRng = Sheet2.Range("K" & rCell.Row).Address 'set the first week cell in rota
                    For x = 1 To WeekLoop 'loop from week 1 to 52
                        Sheet2.Range(tmpRng).Offset(, -2).Value = 1 'one week rota so paints the 1 across rota
                        'moves the week from patterns to rota
                        Sheet2.Range(Sheet2.Range(tmpRng), Sheet2.Range(tmpRng).Offset(, 6)).Value = _
                            Sheet1.Range(Sheet1.Range(FAddress).Offset(, 1), Sheet1.Range(FAddress).Offset(, 7)).Value
                        'replace the times with driver override time
                        For Each pCell In Sheet2.Range(Sheet2.Range(tmpRng), Sheet2.Range(tmpRng).Offset(, 6)).Cells
                            If IsNumeric(pCell.Value) And StartTime <> "" Then
                                pCell.Value = StartTime
                            End If
                        Next pCell
                        tmpRng = Range(tmpRng).Offset(, 9).Address 'skip to next week
                    Next x 'go to next week
                    
                ElseIf Sheet1.Range(FAddress).Offset(1, 0).Value = "" Then 'last line rota of found a pattern
                    WAddress = Sheet1.Range(Sheet1.Range(FAddress), Sheet1.Range(FAddress).End(xlUp)).Address 'offsets up to set the whole pattern
                    tmpRng = Sheet2.Range("K" & rCell.Row).Address 'set the first week cell in rota
                    For x = 1 To WeekLoop
                        Sheet2.Range(tmpRng).Offset(0, -2).Value = SWeek
                        Sheet2.Range(Sheet2.Range(tmpRng), Sheet2.Range(tmpRng).Offset(6)).Value = _
                            Sheet1.Range(Sheet1.Range(WAddress).Find(SWeek).Offset(, 1), Sheet1.Range(WAddress).Find(SWeek).Offset(, 7)).Value
                        For Each pCell In Sheet2.Range(Sheet2.Range(tmpRng), Sheet2.Range(tmpRng).Offset(6)).Cells
                            If IsNumeric(pCell.Value) And StartTime <> "" Then
                                pCell.Value = StartTime
                            End If
                        Next pCell
                        If SWeek = rCell.Offset(, 4).Value Then
                            SWeek = 1
                        Else
                            SWeek = SWeek + 1
                        End If
                        tmpRng = Sheet1.Range(tmpRng).Offset(, 9).Address
                    Next x
                Else 'found a middle point of a rota a pattern
                    WAddress = Sheet1.Range(Sheet1.Range(FAddress).End(xlUp), Sheet1.Range(FAddress).End(xlDown)).Address 'offsets up and down to set the whole pattern
                    tmpRng = Sheet2.Range("K" & rCell.Row).Address
                    For x = 1 To WeekLoop
                        Sheet2.Range(tmpRng).Offset(, -2).Value = SWeek
                        Sheet2.Range(Sheet2.Range(tmpRng), Sheet2.Range(tmpRng).Offset(, 6)).Value = _
                            Sheet1.Range(Sheet1.Range(WAddress).Find(SWeek).Offset(, 1), Sheet1.Range(WAddress).Find(SWeek).Offset(, 7)).Value
                        For Each pCell In Sheet2.Range(Sheet2.Range(tmpRng), Sheet2.Range(tmpRng).Offset(, 6)).Cells
                            If IsNumeric(pCell.Value) And StartTime <> "" Then
                                pCell.Value = StartTime
                            End If
                        Next pCell
                        If SWeek = rCell.Offset(, 4).Value Then
                            SWeek = 1
                        Else
                            SWeek = SWeek + 1
                        End If
                        tmpRng = Sheet1.Range(tmpRng).Offset(, 9).Address
                    Next x
                    
                End If
                
            End If
            
        Next rCell
        
        Call UpdForm
        
        MsgBox "All drivers successfully added" & vbNewLine & vbNewLine & "Will now calculate the workbook", , "Success"
        
    End Sub
    i have removed copy/paste and done what I can think of but the PaintAll macro takes about 2 mins to run. It paints a years worth of patterns for around 150 entries and builds a working rota that produces csv files for external applications.

    any help would be great, even harsh criticism.

    thanks in advance
    Last edited by georgiboy; 09-18-2016 at 12:36 PM.
    I was not told it was impossible, so i did it.

  2. #2
    VBAX Expert
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    572
    Location
    Will try sort this formatting issue out later, it was pasted from iPhone and I need to power up my retro laptop.
    I was not told it was impossible, so i did it.

  3. #3
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,937
    Neither will speed up the VBA code.

  4. #4
    VBAX Expert
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    572
    Location
    Quote Originally Posted by snb View Post
    Neither will speed up the VBA code.
    I know i meant the way it looks in this forum.
    I was not told it was impossible, so i did it.

  5. #5
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,287
    Location
    Sheet2.Select 
        Sheet2.Range("K6").Select 
        For n = 1 To 52 
            Sheet2.Range(ActiveCell, ActiveCell.Offset(294, 7)).ClearContents 
            ActiveCell.Offset(, 9).Select 
        Next n
    Range(ActiveCell, ActiveCell.Offset(294, 7)) = K6:R300
    (9*52) + 11 = 479 [Offset = 9] [K = 11] [Last cleared Column = 486] [K = 11]

    Eliminate 4 'dots' in loop = eliminate 208 operations
    With Sheet2
    For Col = 11 to 479 Step 9 'Check the math
    .Range(Cells(6, Col), Cells(300, Col+7)).ClearContents
    Next Col
    End With
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  6. #6
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    7,287
    Location
    For x = 1 To WeekLoop 
                        Sheet2.Range(tmpRng).Offset(0, -2).Value = SWeek 
                        Sheet2.Range(Sheet2.Range(tmpRng), Sheet2.Range(tmpRng).Offset(6)).Value = _ 
                        Sheet1.Range(Sheet1.Range(WAddress).Find(SWeek).Offset(, 1), Sheet1.Range(WAddress).Find(SWeek).Offset(, 7)).Value 
                        For Each pCell In Sheet2.Range(Sheet2.Range(tmpRng), Sheet2.Range(tmpRng).Offset(6)).Cells 
                            If IsNumeric(pCell.Value) And StartTime <> "" Then 
                                pCell.Value = StartTime 
                            End If 
                        Next pCell 
                        If SWeek = rCell.Offset(, 4).Value Then 
                            SWeek = 1 
                        Else 
                            SWeek = SWeek + 1 
                        End If 
                        tmpRng = Sheet1.Range(tmpRng).Offset(, 9).Address 
                    Next x

    This is static within the loop
    Sheet1.Range(Sheet1.Range(FAddress).Offset(, 1), Sheet1.Range(FAddress).Offset(, 7)).Value
    So
     
    Dim FAddyValue As Variant
    FAddyValue = Sheet1.Range(Sheet1.Range(FAddress).Offset(, 1), Sheet1.Range(FAddress).Offset(, 7)).Value
    Then use FaddyValue in the loop.Eliminates 6 'dots' per loop

    Everytime you use 'Sheet2' within the loop it counts as a 'dot.' By definition, tmpRng is part of Sheet2, therefore doesn't need any such reference.
    With Sheet2
      For x = 1 To WeekLoop 'loop from week 1 to 52
          tmpRng.Offset(, -2).Value = 1
          Range(tmpRng, tmpRng.Offset(, 6)).Value = FAddyValue
    
    If StartTime <> "" Then 'If False, Checking it 52 times won't make it True
    For Each pCell In Range(tmpRng, tmpRng).Offset(, 6)).Cells 
        If IsNumeric(pCell) Then pCell.Value = StartTime 
     Next pCell    
     End If
    I expect the student to do their homework and find all the errrors I leeve in.


    Please take the time to read the Forum FAQ

  7. #7
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,937
    Instead of 'clearing' (.clearcontents) 104 areas in a worksheet, you'd better use a 'clean' template

  8. #8
    VBAX Expert
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    572
    Location
    Thank you for your ideas, I will build them in shortly
    I was not told it was impossible, so i did it.

  9. #9
    VBAX Expert
    Joined
    Mar 2008
    Location
    Kent, England
    Posts
    572
    Location
    Thanks for your help guys the code is now much faster, here is what I have now.

    Sub PaintAllPatterns()    Dim rCell As Range, FAddress As Range, WAddress As Range, pCell As Range, NameRange As Range, tmpRng As Range
        Dim OneWeekRota As Variant, RotaMaxWeek As Long, SWeek As Long, WeekLoop As Long, StartTime As String
        
        'ask if user is sure
        ans = MsgBox("Are you sure" & vbNewLine & vbNewLine & "This will delete all ABS&OT info for the whole year", vbYesNo)
        'make sure user wanted to run macro
        If ans = vbNo Then
            Exit Sub
        End If
        
        'get password
        UFPass.Show
        If Sheet3.Range("Q4").Value = "No" Then
            MsgBox "Wrong password" & vbNewLine & vbNewLine & "Will now exit", vbCritical
            Exit Sub
        End If
        
        'the ammount of weeks to paint for
        WeekLoop = 52
        
        'unprotect the workbook
        Call Unhide
        Call UnProtector
    
    
        'speed up macro
        With Application
            .Calculation = xlCalculationManual
            .ScreenUpdating = False
            .DisplayStatusBar = False
            .EnableEvents = False
        End With
        
        ' clear all from ABS&OT
        With Sheet2
            For x = 11 To 470 Step 9
                .Cells(6, x).Resize(294, 7).ClearContents
            Next x
        End With
        ' clear all from Painted rota
        With Sheet2
            For x = 488 To 947 Step 9
                .Cells(6, x).Resize(294, 7).ClearContents
            Next x
        End With
    
    
        ' extract names from master patterns
        Sheet1.Range("AB4:AB" & Sheet1.Range("Q" & Rows.Count).End(xlUp).Row).Value = _
            Sheet1.Range("Q4:Q" & Sheet1.Range("Q" & Rows.Count).End(xlUp).Row).Value
        ActiveSheet.Range("AB3:AB" & ActiveSheet.Range("AB" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlYes
        'sort the driver names
        ActiveWorkbook.Worksheets("Master patterns").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Master patterns").Sort.SortFields.Add Key:=Sheet1.Range("AB4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        With ActiveWorkbook.Worksheets("Master patterns").Sort
            .SetRange Sheet1.Range("AB4:AB" & Sheet1.Range("AB" & Rows.Count).End(xlUp).Row)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        'remove headings from the name data
        For Each rCell In Sheet1.Range("AB4:AB" & Sheet1.Range("AB" & Rows.Count).End(xlUp).Row).Cells
            If rCell.Value = "Driver Name" Or rCell.Value = "Fixed" Or rCell.Value = "Rotating" Or rCell.Value = "NA" Then
                rCell.ClearContents
            End If
        Next rCell
        're-sort after removing headings
        ActiveWorkbook.Worksheets("Master patterns").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("Master patterns").Sort.SortFields.Add Key:=Range("AB4"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        With ActiveWorkbook.Worksheets("Master patterns").Sort
            .SetRange Range("AB4:AB" & Sheet1.Range("AB" & Rows.Count).End(xlUp).Row)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        'clear drivers from rota page
        Sheet2.Range("A6:A300").ClearContents
        Application.Calculate
        
        'paste new drivers in from master patterns and calculate
        Sheet2.Range("A6:A" & Sheet1.Range("AB" & Rows.Count).End(xlUp).Row + 2).Value = _
            Sheet1.Range("AB4:AB" & Sheet1.Range("AB" & Rows.Count).End(xlUp).Row).Value
        Application.Calculate
    
    
        'sets the search field with the driver names for below next loop
        Set NameRange = Sheet2.Range("A6:A" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row)
    
    
        'populate the painted rota
        For Each rCell In NameRange.Cells 'loops through driver names in the rota tab
            SWeek = rCell.Offset(, 6).Value 'set the start week
            RotaMaxWeek = rCell.Offset(, 4).Value
            Set FAddress = Sheet1.Range("Q5:Q1000").Find(rCell.Value, Sheet1.Range("Q5")).Offset(, -9) 'sets the found driver cell as address string
            StartTime = Format(Sheet1.Range("Q5:Q1000").Find(rCell.Value, Sheet1.Range("Q5")).Offset(, 2).Value, "hh:mm") 'sets drivers override time
            Set tmpRng = Sheet2.Range("K" & rCell.Row) 'set the first week cell in rota
            
            If FAddress.Offset(, -2).Value = 1 Then 'found a one week rota
                OneWeekRota = Sheet1.Range(FAddress.Offset(, 1), FAddress.Offset(, 7)).Value
                
                If StartTime <> "" Then
                    For x = 1 To WeekLoop 'loop from week 1 to 52
                        tmpRng.Offset(, -2).Value = 1 'one week rota so paints the 1 across rota
                        Sheet2.Range(tmpRng, tmpRng.Offset(, 6)).Value = OneWeekRota
                        For Each pCell In Sheet2.Range(tmpRng, tmpRng.Offset(, 6)).Cells 'replace the times with driver override time
                            If IsNumeric(pCell.Value) Then
                                pCell.Value = StartTime 'repalces rota pattern start time with overide time
                            End If
                        Next pCell
                        Set tmpRng = tmpRng.Offset(, 9) 'skip to next week
                    Next x 'go to next week
                Else
                    For x = 1 To WeekLoop 'loop from week 1 to 52
                        tmpRng.Offset(, -2).Value = 1 'one week rota so paints the 1 across rota
                        Sheet2.Range(tmpRng, tmpRng.Offset(, 6)).Value = OneWeekRota 'pastes rota pattern time accross rota
                        Set tmpRng = tmpRng.Offset(, 9) 'skip to next week
                    Next x 'go to next week
                End If
    
    
            ElseIf FAddress.Offset(1, 0).Value = "" Then 'last line of a multi week pattern found
                Set WAddress = Sheet1.Range(FAddress, FAddress.End(xlUp)) 'offsets up to set the whole pattern
                
                If StartTime <> "" Then
                    For x = 1 To WeekLoop
                        tmpRng.Offset(0, -2).Value = SWeek
                        Sheet2.Range(tmpRng, tmpRng.Offset(, 6)).Value = _
                            Sheet1.Range(WAddress.Find(SWeek).Offset(, 1), WAddress.Find(SWeek).Offset(, 7)).Value
                        For Each pCell In Sheet2.Range(tmpRng, tmpRng.Offset(, 6)).Cells
                            If IsNumeric(pCell.Value) Then
                                pCell.Value = StartTime
                            End If
                        Next pCell
                        If SWeek = RotaMaxWeek Then
                            SWeek = 1
                        Else
                            SWeek = SWeek + 1
                        End If
                        Set tmpRng = tmpRng.Offset(, 9)
                    Next x
                Else
                    For x = 1 To WeekLoop
                        tmpRng.Offset(0, -2).Value = SWeek
                        Sheet2.Range(tmpRng, tmpRng.Offset(, 6)).Value = _
                            Sheet1.Range(WAddress.Find(SWeek).Offset(, 1), WAddress.Find(SWeek).Offset(, 7)).Value
                        If SWeek = RotaMaxWeek Then
                            SWeek = 1
                        Else
                            SWeek = SWeek + 1
                        End If
                        Set tmpRng = tmpRng.Offset(, 9)
                    Next x
                End If
                
            Else 'found a middle point of a rota a pattern
                Set WAddress = Sheet1.Range(FAddress.End(xlUp), FAddress.End(xlDown)) 'offsets up and down to set the whole pattern
                
                If StartTime <> "" Then
                    For x = 1 To WeekLoop
                        tmpRng.Offset(, -2).Value = SWeek
                        Sheet2.Range(tmpRng, tmpRng.Offset(, 6)).Value = _
                            Sheet1.Range(WAddress.Find(SWeek).Offset(, 1), WAddress.Find(SWeek).Offset(, 7)).Value
                        For Each pCell In Sheet2.Range(tmpRng, tmpRng.Offset(, 6)).Cells
                            If IsNumeric(pCell.Value) Then
                                pCell.Value = StartTime
                            End If
                        Next pCell
                        If SWeek = RotaMaxWeek Then
                            SWeek = 1
                        Else
                            SWeek = SWeek + 1
                        End If
                        Set tmpRng = tmpRng.Offset(, 9)
                    Next x
                Else
                    For x = 1 To WeekLoop
                        tmpRng.Offset(, -2).Value = SWeek
                        Sheet2.Range(tmpRng, tmpRng.Offset(, 6)).Value = _
                            Sheet1.Range(WAddress.Find(SWeek).Offset(, 1), WAddress.Find(SWeek).Offset(, 7)).Value
                        If SWeek = RotaMaxWeek Then
                            SWeek = 1
                        Else
                            SWeek = SWeek + 1
                        End If
                        Set tmpRng = tmpRng.Offset(, 9)
                    Next x
                End If
     
            End If
            
        Next rCell
        
        Call UpdForm
        
        MsgBox "All drivers successfully added" & vbNewLine & vbNewLine & "Will now calculate the workbook", , "Success"
        
    End Sub
    I hope this looks better now

    Thanks again
    I was not told it was impossible, so i did it.

Posting Permissions

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