Looping first date of week in a month

[Charlie987]

Hi,
Hoping someone might be able to help me adjust this code.
Someone helped me create it so I am not positive how it works (I don't have a lot of experience with VBA)
It aims to print the date twice for each Monday in a user-input month (it prints the date twice for each week).
It works perfectly except where the 31st of the month is the Monday. It is omitting the weeks where Monday is the 31st.
An example is if the user inserts 2021/05/01
it prints:
3/5/21 | 3/5/21 | 10/5/21 | 10/5/21 | 17/05/21 | 17/05/21 | 24/05/21 | 24/05/21
but the 31st should also have been included


Sub SetDates()
Application.ScreenUpdating = False
Dim response As String, d As Date, x As Long, intDay As Integer:
x = 1
intDay = 0

response = InputBox("Enter the date in the format: yyyy/mm/01", "1st of the month")

If Right(response, 2) <> "01" Then
MsgBox ("Enter the darn date correctly")
Exit Sub
End If

d = response

While Format(d + intDay, "mmm") = Format(d + intDay + 1, "mmm")
If Format(d + intDay, "ddd") = "Mon" Then
Cells(1, x).Resize(, 2) = DateSerial(Year(d), Month(d), Format(d + intDay, "d"))
Cells(2, x).Value = "packed"
Cells(2, x + 1).Value = "checked"
x = x + 2
End If
intDay = intDay + 1
Wend

Application.ScreenUpdating = True
End Sub


If any one could point me in the right direction as to how to fix that it would be greatly appreciated.
Thank you very very much.

 

[JackDanIce]

On a new worksheet, try running:

Sub Set_Dates()

    Dim d As Date
    Dim d_list As Variant
   
    Application.ScreenUpdating = False
   
    With ActiveSheet
        'Clear Headers
        .[A1].CurrentRegion.Value = ""
   
        'Get user date
        d = Get_User_First_Monday()
        If d = 0 Then GoTo ExitMe
       
        'Create dates
        d_list = date_list(d)
       
        'Print results
        With .[A1].Resize(UBound(d_list, 2), UBound(d_list, 1))           
            .Value = Application.Transpose(d_list)
            .EntireColumn.AutoFit
        End With
    End With
    Erase d_list
   
ExitMe:
    Application.ScreenUpdating = True
   
End Sub

Private Function Get_User_First_Monday() As Date
       
    On Error Resume Next
    Get_User_First_Monday = DateValue(InputBox("Enter date in format yyyy/mm/01 :", "1st of the Month"))
    On Error GoTo 0
 
    If Day(Get_User_First_Monday) > 1 Then
        MsgBox "Incorrect date, please enter as 1st of the month only!", vbExclamation, "Incorrect Entry"
        Get_User_First_Monday = 0
    Else
        Get_User_First_Monday = DateSerial(Year(Get_User_First_Monday), Month(Get_User_First_Monday), 8) - Weekday(DateSerial(Year(Get_User_First_Monday), Month(Get_User_First_Monday), 6))
    End If
   
End Function

Private Function date_list(d As Date) As Variant
 
    Dim x As Date: x = d
    Dim i As Long
    Dim v As Variant
    Dim labels As Variant: labels = Split("packed|checked", "|")
 
    Do While x <= DateSerial(Year(d), Month(d) + 1, 0)
        i = i + 2
        x = x + 7
    Loop
    x = d
 
    ReDim v(1 To i, 1 To 2)
 
    For i = LBound(v, 1) To UBound(v, 1) Step 2
        v(i, 1) = d: v(i, 2) = labels(0)
        v(i + 1, 1) = d: v(i + 1, 2) = labels(1)
        d = d + 7
    Next i
 
    date_list = v: Erase v: Erase labels
End Function

Tested with values "2021/05/01" and "2021/06/01", output is as needed

If that works, then make a copy of your workbook, then replace your code with above

 

[Charlie987]

That looks perfect! thank you very much.
A couple other things I have to do with it:
how would I adjust that one so that it will only print the dates once this time eg:
3/5/21 | 10/5/21 | 17/05/21 ... etc

The other thing I have to do is I have a list of people and on the press of a button a new workbook is created that contains the list of names duplicated along side each week.
The code I currently have is working perfectly except it is falling victim to the same issue when it comes to the 31st being a Monday
would I be able to adjust your solution to suit this one as well?
This is the code currently using:

Sub DAA_claim()
Application.ScreenUpdating = False
Dim srcWS As Worksheet, LastRow As Long, rng As Range, response As String, d As Date
Set srcWS = ThisWorkbook.Sheets("Private Master Patient List")
LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
response = InputBox("Enter the date in the format: yyyy/mm/01", "1st of the month")
If Right(response, 2) <> "01" Then
MsgBox ("Please enter the date in the format: 'yyyy/mm/01' with '01' as the day.")
Exit Sub
End If
d = response
Workbooks.Add
While Format(d + intDay, "mmm") = Format(d + intDay + 1, "mmm")
If Format(d + intDay, "ddd") = "Mon" Then
srcWS.UsedRange.Offset(1).Copy Cells(Rows.Count, "A").End(xlUp).Offset(1)
Cells(Rows.Count, "F").End(xlUp).Offset(1).Resize(LastRow - 1) = DateSerial(Year(d), Month(d), Format(d + intDay, "d"))
End If
intDay = intDay + 1
Wend
Application.ScreenUpdating = True
End Sub


where the master file contains names eg.
John Lennon
Paul McCartney
Ringo Starr
George Harrison

and the expected output is

John Lennon 3/5/21
Paul McCartney 3/5/21
Ringo Starr 3/5/21
George Harrison 3/5/21
John Lennon 10/5/21
Paul McCartney 10/5/21
Ringo Starr 10/5/21
George Harrison 10/5/21
... etc


Thank you again for your help!!

 

[JackDanIce]

You're welcome

how would I adjust that one so that it will only print the dates once this time eg:
3/5/21 | 10/5/21 | 17/05/21 ... etc

Replace all of the code with

Sub Set_Dates_Single_Date()

    Dim d As Date
    Dim d_list As Variant
   
    Application.ScreenUpdating = False
   
    With ActiveSheet
        'Clear Headers
        .[A1].CurrentRegion.Value = ""
   
        'Get user date
        d = Get_User_First_Monday()
        If d = 0 Then GoTo ExitMe
       
        'Create dates
        d_list = date_list(d)
       
        'Print results
        With .[A1].Resize(, UBound(d_list))
            .Value = d_list
            .EntireColumn.AutoFit
        End With
    End With
    Erase d_list
   
ExitMe:
    Application.ScreenUpdating = True
   
End Sub

Private Function Get_User_First_Monday_Single_Date() As Date
           
    On Error Resume Next
    Get_User_First_Monday = DateValue(InputBox("Enter date in format yyyy/mm/01 :", "1st of the Month"))
    On Error GoTo 0
   
    If Day(Get_User_First_Monday) > 1 Then
        MsgBox "Incorrect date, please enter as 1st of the month only!", vbExclamation, "Incorrect Entry"
        Get_User_First_Monday = 0
    Else
        Get_User_First_Monday = DateSerial(Year(Get_User_First_Monday), Month(Get_User_First_Monday), 8) - Weekday(DateSerial(Year(Get_User_First_Monday), Month(Get_User_First_Monday), 6))
    End If
       
End Function

Private Function date_list_Single_Date(d As Date) As Variant
   
    Dim x As Date: x = d
    Dim i As Long
    Dim v As Variant
   
    Do While x <= DateSerial(Year(d), Month(d) + 1, 0)
        i = i + 1
        x = x + 7
    Loop
    x = d
   
    ReDim v(1 To i)
   
    For i = LBound(v, 1) To UBound(v, 1)
        v(i) = d
        d = d + 7
    Next i
   
    date_list = v: Erase v
   
End Function

 

[JackDanIce]

For the second request, are the names split into two columns? Do you want the content cleared out then replaced with 3 columns of data?
Would be easier if you showed a 'before' and 'after' screenshot

 

[Charlie987]

For the second request, are the names split into two columns? Do you want the content cleared out then replaced with 3 columns of data?
Would be easier if you showed a 'before' and 'after' screenshot

Ok thanks.
These are the before and after images.
I have a bit more code in that sub aswell, just deleting the buttons that seemed to get carried across because I didn't know how to prevent that:
This is it but I am sure it is a very clunky way of doing it (but I have very little knowledge of VBA)
Columns("G:Y").Select
Selection.Delete Shift:=xlToLeft
Columns("D:E").Select
Range("E1").Activate
Selection.Delete Shift:=xlToLeft
Columns("A:D").Select
Range("A:D").Columns.AutoFit
Columns("A:D").Select
end Sub


Thanks again!!