Convert listing of events with dates to calendar - Pls help

[Guest]

Is there a way to convert a table that lists events with dates to a calendar
format? For example, I have

Event Date
Seminar 4/15/2005
Posting 5/4/2005
End 7/20/2005

I would then have individual sheets for the months with the items above in
the appropriate boxes in the month calendar. Any help would be appreciated!

 

[Tom Ogilvy]

I am sure you could using a macro

Seminar, Posting and End are 3 different events?

One challenge would be fitting the information within the "box" which would
depend on the length of the text describing the event and the number of
events which might occur for 1 box (date).

 

[Guest]

yes these are 3 separate events that need to appear on the calendar. I can
work on abbreviations but still need help on how to convert the list and
create separate worksheets in a calendar format for the 12 months.

Thanks!

 

[Tom Ogilvy]

Assumes you have a sheet in the activeworkbook with the name Event List
the first event name is in A2 and the date is in B2 and so forth down the
column with no breaks or interruptions. this should get you started.

Option Explicit
Sub BuildCalendar()
Dim yr As Long
Dim sName As String
Dim StartDate As Date
Dim EndDate As Date
Dim sh As Worksheet
Dim rng As Range, cell As Range
Dim dt As Date, s As String
Dim idex As Long, i As Long
Dim v(1 To 366) As String

With Worksheets("Event List")
dt = .Cells(2, 2).Value
yr = Year(dt)
StartDate = DateSerial(yr, 1, 1)
EndDate = DateSerial(yr, 12, 31)
Set rng = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
End With
For Each cell In rng
idex = cell.Offset(0, 1).Value - StartDate + 1
v(idex) = v(idex) & Chr(10) & cell.Value
Next


For i = 1 To 12
On Error Resume Next
Application.DisplayAlerts = False
sName = Format(DateSerial(yr, i, 1), "mmmm")
Worksheets(sName).Delete
Application.DisplayAlerts = False
On Error GoTo 0
Next i
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
For i = StartDate To EndDate
If Day(i) = 1 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
sh.Name = Format(i, "mmmm")
MakeCalendar sh, yr, v
End If
Next
End Sub


Sub MakeCalendar(sh As Worksheet, yr As Long, v() As String)
Dim dt As Date, dt1 As Date
Dim i As Long, j As Long, k As Long
Dim l As Long, m As Long, n As Long
Dim cell As Range, rw As Long, col As Long
sh.Range("A:G").EntireColumn.ColumnWidth = 22
sh.Rows(1).RowHeight = 35
With sh.Cells(1, 1).Resize(1, 7)
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
sh.Cells(1, 1).Value = "'" & sh.Name & " " & yr
sh.Cells(1, 1).Font.Bold = True
sh.Cells(1, 1).Font.Size = 35
With sh.Cells(2, 1).Resize(1, 7)
.Value = Array("Sunday", "Monday", _
"Tuesday", "Wednesday", "Thursday", _
"Friday", "Saturday")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
.Font.Size = 16
.EntireRow.RowHeight = 18
End With
For Each cell In sh.Cells(2, 1).Resize(7, 7)
cell.BorderAround Weight:=xlMedium
cell.WrapText = True
If cell.Row >= 3 Then
cell.HorizontalAlignment = xlGeneral
cell.VerticalAlignment = xlTop
End If
Next
dt = DateValue(sh.Name & " 1," & yr)
i = Weekday(dt, vbSunday)
dt1 = DateSerial(Year(dt), Month(dt) + 1, 0)
n = dt - DateSerial(Year(dt), 1, 1)
col = i
rw = 3
For k = Day(dt) To Day(dt1)
n = n + 1
Cells(rw, col).Value = Trim(k & v(n))
Cells(rw, col).BorderAround Weight:=xlMedium
col = col + 1
If col > 7 Then
col = 1
rw = rw + 1
End If
Next
sh.Cells(3, 1).Resize(6, 1).EntireRow.RowHeight = 50
End Sub

 

[Tom Ogilvy]

One formatting mistake that affects cells with no events. Here is the
corrected code:

Option Explicit
Sub BuildCalendar()
Dim yr As Long
Dim sName As String
Dim StartDate As Date
Dim EndDate As Date
Dim sh As Worksheet
Dim rng As Range, cell As Range
Dim dt As Date, s As String
Dim idex As Long, i As Long
Dim v(1 To 366) As String

With Worksheets("Event List")
dt = .Cells(2, 2).Value
yr = Year(dt)
StartDate = DateSerial(yr, 1, 1)
EndDate = DateSerial(yr, 12, 31)
Set rng = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
End With
For Each cell In rng
idex = cell.Offset(0, 1).Value - StartDate + 1
v(idex) = v(idex) & Chr(10) & cell.Value
Next


For i = 1 To 12
On Error Resume Next
Application.DisplayAlerts = False
sName = Format(DateSerial(yr, i, 1), "mmmm")
Worksheets(sName).Delete
Application.DisplayAlerts = False
On Error GoTo 0
Next i
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
For i = StartDate To EndDate
If Day(i) = 1 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set sh = ActiveSheet
sh.Name = Format(i, "mmmm")
MakeCalendar sh, yr, v
End If
Next
End Sub
Sub MakeCalendar(sh As Worksheet, yr As Long, v() As String)
Dim dt As Date, dt1 As Date
Dim i As Long, j As Long, k As Long
Dim l As Long, m As Long, n As Long
Dim cell As Range, rw As Long, col As Long
sh.Range("A:G").EntireColumn.ColumnWidth = 22
sh.Rows(1).RowHeight = 35
With sh.Cells(1, 1).Resize(1, 7)
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
sh.Cells(1, 1).Value = "'" & sh.Name & " " & yr
sh.Cells(1, 1).Font.Bold = True
sh.Cells(1, 1).Font.Size = 35
With sh.Cells(2, 1).Resize(1, 7)
.Value = Array("Sunday", "Monday", _
"Tuesday", "Wednesday", "Thursday", _
"Friday", "Saturday")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
.Font.Size = 16
.EntireRow.RowHeight = 18
End With
For Each cell In sh.Cells(2, 1).Resize(7, 7)
cell.BorderAround Weight:=xlMedium
cell.WrapText = True
If cell.Row >= 3 Then
cell.HorizontalAlignment = xlLeft
cell.VerticalAlignment = xlTop
End If
Next
dt = DateValue(sh.Name & " 1," & yr)
i = Weekday(dt, vbSunday)
dt1 = DateSerial(Year(dt), Month(dt) + 1, 0)
n = dt - DateSerial(Year(dt), 1, 1)
col = i
rw = 3
For k = Day(dt) To Day(dt1)
n = n + 1
Cells(rw, col).Value = Trim(k & v(n))
Cells(rw, col).BorderAround Weight:=xlMedium
col = col + 1
If col > 7 Then
col = 1
rw = rw + 1
End If
Next
sh.Cells(3, 1).Resize(6, 1).EntireRow.RowHeight = 50
End Sub

 

[Guest]

Thanks for the code! I'll give it a go....Regards,
Jennifer