georgiboy
09-18-2016, 10:28 AM
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
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