Any thoughts on speeding up these macros, I'm not asking for anyone to do it for me just suggestions would be cool
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.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
any help would be great, even harsh criticism.
thanks in advance
Reply With Quote