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

Code:

---

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

Will try sort this formatting issue out later, it was pasted from iPhone and I need to power up my retro laptop.

Neither will speed up the VBA code.

Quote:

---

Originally Posted by snb

Neither will speed up the VBA code.

---

I know i meant the way it looks in this forum.

Code:

---

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

Code:

---

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

---

Code:

---

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

Code:

---

Sheet1.Range(Sheet1.Range(FAddress).Offset(, 1), Sheet1.Range(FAddress).Offset(, 7)).Value

---

So

Code:

---


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.

Code:

---

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

---

Instead of 'clearing' (.clearcontents) 104 areas in a worksheet, you'd better use a 'clean' template

Thank you for your ideas, I will build them in shortly :)

Thanks for your help guys the code is now much faster, here is what I have now.

Code:

---

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