Adjust date week

Try this modified macro

Option Explicit

Sub DDWEEK()
Dim ws As Worksheet
Dim num As Long, i As Long, j As Long, n As Long, lr As Long
Dim numYear As Long
Dim x()

numYear = Application.InputBox("Enter the Year", "Year!", 2018, Type:=1)
If Len(numYear) <> 4 Then
    MsgBox "Enter the Year in four digits.", vbExclamation
    Exit Sub
End If

Set ws = Sheets("DDWEEK")
num = 52
ReDim x(1 To num * 2, 1 To 2)

For i = 1 To num * 2 Step 2
    n = n + 1
    For j = 1 To 1
        x(i, 1) = n & "W" & numYear
        x(i, 2) = "A"
        x(i + j, 1) = n & "W" & numYear
        x(i + j, 2) = "B"
    Next j
Next i
lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
If lr > 2 Then ws.Range("A3:B" & lr).Clear
ws.Range("A3").Resize(UBound(x, 1), 2).Value = x
End Sub
Sub AddToDays()
Dim lngLastRow As Long
Dim lngRow As Long
Dim dteNext As Date
Dim intYear As Integer
Dim strWeek As String

intYear = InputBox("Please enter year", "Year", Year(Now))
dteNext = "1/1/" & intYear

'Do Until Weekday(dteNext) = 2
'    dteNext = dteNext + 1
'Loop
If Weekday(dteNext) = 1 Then
    dteNext = dteNext + 1
Else
    dteNext = dteNext - Weekday(dteNext) + 2
End If

lngRow = 5
strWeek = "1W" & intYear

ActiveSheet.UsedRange.Cells.Offset(3, 0).ClearContents

Do
    Cells(lngRow, "A") = strWeek
    With Cells(lngRow, "A").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.349986266670736
        .PatternTintAndShade = 0
    End With
    Cells(lngRow, "A").HorizontalAlignment = xlLeft

    lngRow = lngRow + 1
    For lngRow = lngRow To lngRow + 10 Step 2
    If Year(dteNext) = intYear Then
        Cells(lngRow, "A") = Format(dteNext, "DDDD, MMMM DD, YYYY")
        Cells(lngRow, "A").HorizontalAlignment = xlRight
        Cells(lngRow + 1, "A") = Format(dteNext, "DDDD, MMMM DD, YYYY")
        Cells(lngRow + 1, "A").HorizontalAlignment = xlRight
    End If
    dteNext = dteNext + 1
    Next
    strWeek = Split(strWeek, "W")(0) + 1 & Right$(strWeek, 5)
    If Split(strWeek, "W")(0) = 53 Then
        Exit Do
    End If
    dteNext = dteNext + 1
Loop Until Year(dteNext) > intYear
End Sub

Select allOpen in new window

Saqib Husain, Syed

Thanks for the fast response

can you provied an working sample i don't know how work with the code

Great Job !

Thanks ! Great Expert