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