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