Problem with a do loop

[Regouin]

the following VBA file keeps telling me that i have a Do without a loop and when I insert a loop it tells me that it has a loop without a do. I am quite lost at where the problem is. (if you have some tweaks for the code please feel welcome to suggest, because I am quite new at this and tend to use codes from which I know that they work)

this is the VBA

Sub regouin()
    Dim yr As Integer, WS As Worksheet, SDate As Date, wks As Integer, i As Integer, leap As String
    On Error Resume Next
    yr = InputBox(Prompt:="Please enter year", Default:=Year(Date))
    On Error GoTo 0
    If yr = 0 Then Exit Sub
    If Not IsDate(DateSerial(yr, 1, 1)) Then Exit Sub
    Application.ScreenUpdating = False
    SDate = DateSerial(yr, 1, 1)
    Worksheets("kalender").Range("b1").FormulaR1C1 = yr
    leap = Worksheets("kalender").Range("l6")
    On leap = "ja" GoSub schrikkel
    If Weekday(SDate) = 5 Then wks = 53 Else wks = 52
If Weekday(SDate) < 5 Then
    Do Until Weekday(SDate, vbMonday) = 1
    SDate = SDate - 1
    If Weekday(SDate) = vbMonday Then GoTo invul Else:
    Do Until Weekday(SDate, vbMonday) = 1
    SDate = SDate + 1
invul:
    Do
    Loop
    Range("A1:G1") = Array("Week nummer", "Start datum", "Eind datum", "Linker Voorwas", "Rechter Voorwas", "Hoofdwas 1", "Hoofdwas 2")
    Range("A2:C2") = Array(1, SDate + 1, SDate + 7)
    For i = 2 To wks
        Range("A1:C1").Offset(i, 0) = Array(i, SDate + (7 * (i - 1)), SDate + (7 * (i - 1)) + 6)
    Next i
    Columns.AutoFit
    Application.ScreenUpdating = True
    Exit Do
End Sub

Sub schrikkel()
If Weekday(SDate) = 5 Or Weekday(SDate) = 4 Then wks = 53 Else wks = 52
If Weekday(SDate) < 5 Then
    Do Until Weekday(SDate, vbMonday)
    SDate = SDate - 1
    If Weekday(SDate) = vbMonday Then GoTo invuls Else:
    Do Until Weekday(SDate, vbMonday)
    SDate = SDate + 1
invuls:
    Loop
    Range("A1:G1") = Array("Week number", "Starting date", "Ending date", "#1", "#2", "#3", "#4")
    Range("A2:C2") = Array(1, SDate, SDate + 6)
    For i = 2 To wks
        Range("A1:C1").Offset(i, 0) = Array(i, SDate + (7 * (i - 1)), SDate + (7 * (i - 1)) + 6)
    Next i
    Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

and I'll attach the whole workbook

TIA
Frank

[Regouin]

hello again,

ok i have the do problem fixed

Sub Kalender()
    Dim yr As Integer, WS As Worksheet, SDate As Date, wks As Integer, i As Integer, leap As String
    On Error Resume Next
    yr = InputBox(Prompt:="Please enter year", Default:=Year(Date))
    On Error GoTo 0
    If yr = 0 Then Exit Sub
    If Not IsDate(DateSerial(yr, 1, 1)) Then Exit Sub
    Application.ScreenUpdating = False
    SDate = DateSerial(yr, 1, 1)
    Worksheets("kalender").Range("b1").FormulaR1C1 = yr
    leap = Worksheets("kalender").Range("l6")
    If leap = "ja" Then GoTo schrikkel
    If Weekday(SDate) = 5 Then wks = 53 Else wks = 52
If Weekday(SDate) <= 5 Then GoTo doloop1 Else GoTo doloop2
doloop1:
    Do Until Weekday(SDate, vbMonday) = 1
    SDate = SDate - 1
Loop
    Range("A2:G2") = Array("Week nummer", "Start datum", "Eind datum", "Linker Voorwas", "Rechter Voorwas", "Hoofdwas 1", "Hoofdwas 2")
    Range("A3:C3") = Array(1, SDate, SDate + 6)
    For i = 2 To wks
        Range("A2:C2").Offset(i, 0) = Array(i, SDate + (7 * (i - 1)), SDate + (7 * (i - 1)) + 6)
    Next i
    If wks = 52 Then Range("a55:c55").Delete
    Application.ScreenUpdating = True
    GoTo einde
doloop2:
    Do Until Weekday(SDate, vbMonday) = 1
    SDate = SDate + 1
Loop
    Range("A2:G2") = Array("Week nummer", "Start datum", "Eind datum", "Linker Voorwas", "Rechter Voorwas", "Hoofdwas 1", "Hoofdwas 2")
    Range("A3:C3") = Array(1, SDate, SDate + 6)
    For i = 2 To wks
        Range("A2:C2").Offset(i, 0) = Array(i, SDate + (7 * (i - 1)), SDate + (7 * (i - 1)) + 6)
    Next i
    If wks = 52 Then Range("a55:c55").Delete
    Application.ScreenUpdating = True
    GoTo einde
schrikkel:
    If Weekday(SDate) = 5 Or Weekday(SDate) = 4 Then wks = 53 Else wks = 52
    If Weekday(SDate) <= 5 Then GoTo doloop3 Else GoTo doloop4
doloop3:
Do Until Weekday(SDate, vbMonday) = 1
    SDate = SDate - 1
Loop
    Range("A2:G2") = Array("Week nummer", "Start datum", "Eind datum", "Linker Voorwas", "Rechter Voorwas", "Hoofdwas 1", "Hoofdwas 2")
    Range("A3:C3") = Array(1, SDate, SDate + 6)
    For i = 2 To wks
        Range("A2:C2").Offset(i, 0) = Array(i, SDate + (7 * (i - 1)), SDate + (7 * (i - 1)) + 6)
    Next i
    If wks = 52 Then Range("a55:c55").Delete
    Application.ScreenUpdating = True
    GoTo einde
doloop4:
    Do Until Weekday(SDate, vbMonday) = 1
    SDate = SDate + 1
Loop
    Range("A2:G2") = Array("Week nummer", "Start datum", "Eind datum", "Linker Voorwas", "Rechter Voorwas", "Hoofdwas 1", "Hoofdwas 2")
    Range("A3:C3") = Array(1, SDate, SDate + 6)
    For i = 2 To wks
        Range("A2:C2").Offset(i, 0) = Array(i, SDate + (7 * (i - 1)), SDate + (7 * (i - 1)) + 6)
    Next i
    If wks = 52 Then Range("a55:c55").Delete
    Application.ScreenUpdating = True
    GoTo einde
einde:
End Sub

problem is that when you once had a year with 53 weeks the 53rd week stays there when you change the year, I am working on this now, but it might be a usual piece of code if the leap-year business is implemented in the VBA and not on the sheet as it is now. (*edit*) fixed the 53rd week by adding the delete line (*/edit*)