PDA

View Full Version : [SOLVED] Speed up VBA code



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

georgiboy
09-18-2016, 11:22 AM
Will try sort this formatting issue out later, it was pasted from iPhone and I need to power up my retro laptop.

snb
09-18-2016, 12:03 PM
Neither will speed up the VBA code.

georgiboy
09-18-2016, 12:30 PM
Neither will speed up the VBA code.

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

SamT
09-18-2016, 03:47 PM
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

SamT
09-18-2016, 04:12 PM
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

snb
09-18-2016, 11:58 PM
Instead of 'clearing' (.clearcontents) 104 areas in a worksheet, you'd better use a 'clean' template

georgiboy
09-19-2016, 02:20 AM
Thank you for your ideas, I will build them in shortly :)

georgiboy
09-21-2016, 02:33 AM
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