Grouping by Date?

[pjbltd]

Hi guys,

New to the forum, hoping could get some help with the following
I am using Excel 2010 to create a calendar or date plan.
I want to have a seperate row for each date and then I want the corresponding dates to be grouped by month:

A B C D E
1 June 2011 Comment
2 01/06/2011 Wed June 2011 Comment
3 02/06/2011 Thurs June 2011
......
31 30/06/2011 Thurs June 2011 Comment
31 July 2011 Comment
32 01/07/2011 ........................

This way each month can have a headline comment and everyday also.
I want to do this for many years
Is there a quick way to automate doing this?

Hope this is clear.
Many thanks,

pjbltd

 

[ColinKJ]

Hi pjbltd,

The following code will give you the calendar, it starts by asking how many years you want, and it highlights the start of each month:

Sub Dates()
Dim dt As Date
a = InputBox("Enter Number Of Required Years")
If IsNumeric(a) = False Then
MsgBox ("Your Entry Must Be Numeric")
GoTo endd
End If
a = Val(a)
ro = 0: clr = 6
mths = Array("January", "February", "March", "April", "May", "June", "July", "August", "Sepember", "October", "November", "December")
dy = Array("Monday", "Tuesday", "Wednesday", "Thursady", "Friday", "Saturday", "Sunday")
dt = "1/1/" & Year(Now())
dtt = dt
ct = 0: Dim x As String
Do While Year(dt) <= (Year(dtt) + (a - 1))
    mmth = Month(dt)
    ct = ct + 1: ro = ro + 1
    Cells(ro, 1) = ct
    Cells(ro, 2) = mths(Month(dt) - 1)
    Cells(ro, 3) = Year(dt)
    Range("A" & ro & ":E" & ro).Select
    Selection.Interior.ColorIndex = 6
    Do While Month(dt) = mmth
        ct = ct + 1: ro = ro + 1
        Cells(ro, 1) = ct
        x = Day(dt) & "/" & Month(dt) & "/" & Year(dt)
        Cells(ro, 2) = x
        Cells(ro, 3) = dy(Weekday(dt) - 1)
        Cells(ro, 4) = mths(Month(dt) - 1)
        Cells(ro, 5) = Year(dt)
        Range("A" & ro & ":E" & ro).Select
 
        dt = dt + 1
    Loop
Loop
endd:
End Sub

I've also put together an example WB called Calendar, which you can download from:

http://www.box.net/shared/djnmn6lgqy9hrqpf1yx9

Ctrl+q starts the routine.

 

[pjbltd]

Thanks ColinKJ, that's awesome!
Anyway to get it to add group outlines?

 

[pjbltd]

the days of the week for the dates is wrong, e.g. 1/1/2011 was a Saturday not a Sunday

please could you take a look

 

[wigi]

the days of the week for the dates is wrong, e.g. 1/1/2011 was a Saturday not a Sunday

please could you take a look

The function Weekday accepts 2 arguments, have a look at the second one (the start of the week).

 

[ColinKJ]

Hi pjbltd,

Sorry about that, should have checked it. You need to change the Array to this one:

dy = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursady", "Friday", "Saturday")

I've also updated the example:

http://www.box.net/shared/djnmn6lgqy9hrqpf1yx9

 

[pjbltd]

Brilliant thanks Colin.

I want to create a tab with recurring dates with their day & month e.g.
XMAS 31/12
Dad Birthday 01/03

And then these to automatically fill the calendar.

Is this possible?

 

[ColinKJ]

Hi pjbltd,

I've got a busy day to day, but will get back with something later.

 

[ColinKJ]

Hi pjbltd,

Here is the code:

Sub SaveDates()
If Cells(2, 1) = "" Then GoTo endd
If Sheets(1).Cells(1, 1) = "" Then
MsgBox ("You Must First Create A Calendar")
GoTo endd
End If
ro = 2
Do While Cells(ro, 1) <> ""
    a = Cells(ro, 2).Text
    For b = 1 To Len(a)
        If Mid$(a, b, 1) = "/" Then
            d = Val(Mid$(a, 1, b - 1))
            m = Val(Mid$(a, b + 1))
            GoTo x
        End If
    Next b
    MsgBox ("There Is Not A Valid Date In Row " & ro)
    GoTo endd
x:
With Sheets(1)
R = .Range("A" & Rows.Count).End(xlUp).Row
For y = 1 To R
    If Len(.Cells(y, 2).Text) > 5 Then
        If Mid$(.Cells(y, 2).Text, 1, Len(.Cells(y, 2).Text) - 5) = a Then
            .Cells(y, 6) = Cells(ro, 1)
        End If
    End If
Next y
End With
z:
ro = ro + 1
Loop
MsgBox ("All Done")
endd:
End Sub

I've also updated the example WB Calendar which you can download from:

http://www.box.net/shared/djnmn6lgqy9hrqpf1yx9

You'll see on the example, sheet 2 I've entered some example entries.
Clicking on the Save button buts the items from column A into the Calendar repeated for each year of the Calendar.

If you try before you've created the Calendar you get a message.

 

[Biz]

Hi Colin,

If I use Option Explicit I don't get correct results. Dates are mixed as it has US dates but I need UK dates.

Sub Dates()
Dim dt As Date, dtt As Date
Dim a As Integer, mmth As Integer
Dim ro As Long, clr As Long, ct As Long
Dim mths, dy

Biz