Looping first date of week in a month

Charlie987

New Member
Joined
Jul 25, 2020
Messages
25
Office Version
  1. 365
Platform
  1. Windows
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
Joined
Feb 3, 2010
Messages
9,890
Office Version
  1. 365
Platform
  1. Windows
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
        '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
 
Last edited:

Charlie987

New Member
Joined
Jul 25, 2020
Messages
25
Office Version
  1. 365
Platform
  1. Windows
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

Well-known Member
Joined
Feb 3, 2010
Messages
9,890
Office Version
  1. 365
Platform
  1. Windows
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
        '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

Well-known Member
Joined
Feb 3, 2010
Messages
9,890
Office Version
  1. 365
Platform
  1. Windows
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
Joined
Jul 25, 2020
Messages
25
Office Version
  1. 365
Platform
  1. Windows
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
    before.png
    57.1 KB · Views: 4
  • After.png
    After.png
    73 KB · Views: 1
Master Excel Bundle

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.

Forum statistics

Threads
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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Top