Adjust date week

ADRIANA P
ADRIANA P used Ask the Experts™
on
need fix this tool

as 1 week of the year 2020 is not correct

n1.PNGdate_T.xlsm
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
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

Open in new window

ADRIANA PACCOUNTING ASSISTANT

Author

Commented:
Saqib Husain, Syed

Thanks for the fast response

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

Author

Commented:
Great Job !

Thanks ! Great Expert

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial