Looping first date of week in a month

Charlie987

New Member
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.

Last edited by a moderator:

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

JackDanIce

Well-known Member
On a new worksheet, try running:
VBA Code:
``````Sub Set_Dates()

Dim d As Date
Dim d_list As Variant

Application.ScreenUpdating = False

With ActiveSheet
.[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

Last edited:

Charlie987

New Member
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
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

Well-known Member
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
VBA Code:
``````Sub Set_Dates_Single_Date()

Dim d As Date
Dim d_list As Variant

Application.ScreenUpdating = False

With ActiveSheet
.[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

Well-known Member
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

New Member
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!!

Attachments

• before.png
57.1 KB · Views: 4
• After.png
73 KB · Views: 1

Replies
1
Views
85
Replies
3
Views
285
Replies
1
Views
97
Replies
3
Views
266
Replies
2
Views
160

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

1,152,237
Messages
5,768,983
Members
425,507
Latest member
NrthnChrs

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back