Dynamically adding Calendar dates to table

[Slicemahn]

Hello VBE nation!

I am looking to add dates to a table dynamically but I am having a problem writing the code. What I would like to do is add the dates to a table (which will be part of a dashboard) to a table; however the dates have to added so that:

• no Sundays are shown
• all dates are grouped by week

I have attached the spreadsheet with the before and after. What is more, I would need this code to be able to handle the different months going forward.

[Bob Phillips]

You know, an empty workbook is a bit difficult to glean anythiing from.

[Slicemahn]

My apologies.. it must be my Win Zip. I have reattached the file.

[GTO]

Greetings,

This appears to be working reliably, but it appears to be a brain-fade day, so I've listed the code to the userform in case anyone spots any error(s) in my logic. In short - it seemed to me that if you are starting with the first Monday of the month, then you would want it to end on the Saturday that falls two days prior to the first Monday of the next month. Hopefully this does that.

In the attached wb, I did NOT build any "safetys" as to when you can run the userform. So you want to make sure to have a fresh/blank month's sheet prior to running.

Of course change to suit, but for the example, I just chose to add a shortcut key combo of CTRL + d to run the userform. You will find this under ThisWorkbook, the Activate and Deactivate events.

Hope this helps,

Mark
[vba]Option Explicit

Private Sub cmdCancel_Click()
Unload frmPickMonth
End Sub

Private Sub cmdOK_Click()
Dim _
intMonth As Integer, _
intYear As Integer, _
intFirstDayOfWeek As Integer, _
intDaysInMonth As Integer, _
intFirstDayOfMonth As Integer, _
intFirstDayOfNextMonth As Integer, _
i As Integer, _
rCell As Range

Dim aDates()

intMonth = Me.cboMonth.Column(1)
intYear = Me.cboYear
intFirstDayOfWeek = Weekday(DateSerial(intYear, intMonth, 1), vbMonday)
intFirstDayOfNextMonth = Weekday(DateSerial(intYear, intMonth + 1, 1), vbMonday)
intDaysInMonth = Day(DateSerial(intYear, intMonth + 1, 1) - 1)

Select Case intFirstDayOfWeek
Case 7
intFirstDayOfMonth = 2
Case 6
intFirstDayOfMonth = 3
Case 5
intFirstDayOfMonth = 4
Case 4
intFirstDayOfMonth = 5
Case 3
intFirstDayOfMonth = 6
Case 2
intFirstDayOfMonth = 7
Case 1
intFirstDayOfMonth = 1
End Select

Select Case intFirstDayOfNextMonth
Case 7
intFirstDayOfNextMonth = 2
Case 6
intFirstDayOfNextMonth = 3
Case 5
intFirstDayOfNextMonth = 4
Case 4
intFirstDayOfNextMonth = 5
Case 3
intFirstDayOfNextMonth = 6
Case 2
intFirstDayOfNextMonth = 7
Case 1
intFirstDayOfNextMonth = 1
End Select

ReDim aDates(1 To intDaysInMonth)

i = 1
Do While Not DateSerial(intYear, intMonth, intFirstDayOfMonth) = _
DateSerial(intYear, intMonth + 1, intFirstDayOfNextMonth)

If Not Weekday(DateSerial(intYear, intMonth, intFirstDayOfMonth), vbMonday) = 7 Then
aDates(i) = DateSerial(intYear, intMonth, intFirstDayOfMonth)
i = i + 1
End If
intFirstDayOfMonth = intFirstDayOfMonth + 1
Loop

i = 1

On Error GoTo BailOut
Range("B5:B10,B14:B19,B23:B28,B32:B37,B41:B46").ClearContents
For Each rCell In Range("B5:B10,B14:B19,B23:B28,B32:B37,B41:B46")
rCell = aDates(i)
i = i + 1
Next

BailOut:
Unload Me
End Sub

Private Sub UserForm_Initialize()
Dim i As Integer
Dim aMonths(1 To 12, 1 To 2)
Dim aTmp()

With frmPickMonth
.Caption = "Date Picker"
With .lblYear
.Left = 12
.Top = 14
.Height = 16
.Font.Size = 9
.Caption = "Pick the Year"
.Width = 68
End With
With .lblMonth
.Left = 12
.Top = 36 '12 + 16 + 6 + 2
.Height = 16
.Font.Size = 9
.Caption = "Pick the Month"
.Width = 68
End With
With .cboYear
.Left = 12 + lblYear.Width + 2
.Top = 12
.Height = 16
.Font.Size = 8
.Width = 68
.List = Array("2009", "2010", "2011", "2012", "2013")
.Value = Year(Date)
End With
With .cboMonth
.Left = 12 + lblMonth.Width + 2
.Top = 34
.Height = 16
.Font.Size = 8
.Width = 68

.ColumnHeads = True
.ColumnCount = 2
.ColumnWidths = "67.95 pt;0 pt"

aTmp() = Array("January", "February", "March", "April", "May", "June", _
"July", "August", "September", "October", "November", "December")

For i = 1 To 12
aMonths(i, 1) = aTmp(i - 1)
aMonths(i, 2) = i
Next

.List = aMonths()
.ListIndex = Month(Date) - 1
End With
With .cmdOK
.Left = lblMonth.Left
.Top = lblMonth.Top + lblMonth.Height + 6
.Height = 22
.Font.Size = 11
.Caption = "OK"
.Width = 68
.Accelerator = "O"
End With
With .cmdCancel
.Left = cmdOK.Left + cmdOK.Width + 6
.Top = cmdOK.Top
.Height = 22
.Font.Size = 11
.Caption = "Cancel"
.Width = 68
.Accelerator = "C"
End With
.Height = 112
.Width = 166
End With
End Sub[/vba]

[mdmackillop]

[vba]Option Explicit
Sub SetDates()
Dim Dte As String, Mth As String
Dim k As Long, d As Long, i As Long, j As Long
Dim FirstRun As Boolean

Columns(2).ClearContents 'For debug testing
FirstRun = True
Mth = InputBox("Insert month", , Format(Date, "mmm"))
Dte = "/" & Mth & "/2009"
d = 1
k = Weekday(d & Dte)
For i = 0 To 63 Step 9
For j = 1 To 7
If FirstRun = True Then j = k
FirstRun = False
If Not IsDate(d & Dte) Then Exit Sub
If Weekday(d & Dte) <> 1 Then Cells(3 + i + j, 2) = d & Dte
d = d + 1
Next
Next
End Sub

[/vba]