Sub GetPayDates()
    Dim rr As Range
    With ActiveSheet
        Set rr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 4).End(xlUp))
    End With
    Dim arr As Variant
    arr = JobRange(rr)
    With Workbooks.Add(1)
        With .Sheets(1)
            With .Cells(1, 1)
                With .Resize(UBound(arr(0), 1), UBound(arr(0), 2))
                    .Value = arr(0)
                    .EntireColumn.AutoFit
                End With
                With .Cells(1, 1 + UBound(arr(0), 2)).Resize(UBound(arr(1), 1), UBound(arr(1), 2))
                    .Value = arr(1)
                    .EntireColumn.AutoFit
                End With
            End With
        End With
        .Saved = True
    End With
End Sub
Private Function JobRange(rr As Range) As Variant
    Dim yy As Long
    Dim xx As Long
    Dim arr As Variant
    Dim brr As Variant
    Dim dd As Byte
    Dim mm As Byte
    Dim ye As Long
    Dim dt As Date
    yy = WorksheetFunction.Max(rr.Columns(4))
    arr = rr
    ReDim brr(1 To UBound(arr, 1), 1 To yy)
    For yy = 2 To UBound(arr, 1)
        dd = Day(arr(yy, 2))
        mm = Month(arr(yy, 2))
        ye = Year(arr(yy, 2))
        For xx = 1 To arr(yy, 4)
            dt = DateSerial(ye, mm + xx, dd)
            If Month(dt) = 1 Then
                If Day(dt) < 10 Then dt = DateSerial(ye, 1, 10)
            End If
            If Weekday(dt, vbMonday) = 6 Then dt = dt + 2
            If Weekday(dt, vbMonday) = 7 Then dt = dt + 1
            
            brr(yy, xx) = dt
        Next
    Next
    JobRange = Array(arr, brr)
End Function