Monthly Event Schedule (format like that)

Could someone help me to use Excel Formula to create Monthly Event Schedule as shown in the Sheet named "January 2010" in the attached file?

The Monthly Event Schedule is automatically generated from the Sheet named "Master_Plan".

As when the user inputs data of every events and inserts new Sheet, renames the Sheet with a name of a certain month of the year 2010, the Monthly Event Schedule is generated as well as updated by linking with the Sheet "Master_Plan".

I have do somethings already but can not continue to input formula to create the Monthly Event Schedule with the format like that.

Hope someone could help me!

hi ExelFinder
Would the new sheet be created from a button?

I'm not entirely clear what you want. i.e. I don't know which sheet you envision as the input sheet, Master or the month sheet.

What I've done in the attached is:
1) change the merged cells to CenterAcrossSelection
2) create a dynamic named range DataRange of the data on Master Plan
3) Put the UDF, EventForDay in the cells of January 2010.
EventForDay(dateSought, dataRange, columnsReturned1, columnsReturned2,..)
Will search the top row of the dataRange to find the dateSought, then, for each non-empty cell in the found column, an event string will be created with the data in the columns indicated by the columnsReturned arguments. These event strings will then be sorted by start time and concatenated into a string desribing all of that day's events.

=EventForDay(Date(2010, 1, 4),dataRange, 2, 1)
will create event strings from the first and fourth columns (Event, Person in Charge) of dataRange.

the formula in your case is =EventsForDay(E3,DataRange,1,2,"time",3,4)

Function EventsForDay(dateSought As Double, dataRange As Range, ParamArray columnsReturned() As Variant) As String
    Dim HeadersArray As Variant
    Dim halfDayEvents As String, fullDayEvents As String
    Dim oneEventString As String, eventDelimiter As String: eventDelimiter = vbCr
    Dim rangeToSearch As Range
    Dim i As Long, oneCell As Range, testLen As Long
    Dim resultstr As String
    
    On Error GoTo Halt
    With dataRange.Rows(1)
        With .Cells(1, Application.Match(dateSought, .Cells, 0)).EntireColumn
            Set rangeToSearch = Application.Intersect(dataRange, .Cells)
        End With
    End With
    Set rangeToSearch = Application.Intersect(rangeToSearch, rangeToSearch.Offset(1, 0))
    On Error GoTo 0
    
    HeadersArray = columnsReturned
    For i = LBound(columnsReturned) To UBound(columnsReturned)
        If columnsReturned(i) = "time" Then
            HeadersArray(i) = "Time: "
        Else
            HeadersArray(i) = CStr(dataRange.Cells(1, columnsReturned(i)).Value) & ": "
        End If
    Next i
    
    For Each oneCell In rangeToSearch
        With oneCell
            If .Value <> vbNullString Then
            Rem if there is an event, make string describing it
            oneEventString = vbNullString
            For i = LBound(columnsReturned) To UBound(columnsReturned)
                If HeadersArray(i) = "Time: " Then
                    oneEventString = oneEventString & _
                                                    HeadersArray(i)
                                                    
                    Select Case LCase(CStr(.Value))
                        Case "am"
                            oneEventString = oneEventString & _
                                                    "8:30 - 12:00" _
                                                    & vbCr
                        Case "pm"
                            oneEventString = oneEventString & _
                                                    "13:30 - 17:00" _
                                                    & vbCr
                        Case Else
                            oneEventString = oneEventString & _
                                                    "8:30 - 17:00" _
                                                    & vbCr
                    End Select
                Else
                    With .EntireRow
                        oneEventString = oneEventString & _
                                                    HeadersArray(i) & _
                                                    CStr(Application.Intersect(.Cells, dataRange.Columns(columnsReturned(i))).Value) _
                                                    & vbCr
                                                   
                    End With
                End If
            Next i
                If oneEventString <> vbNullString Then
                    Select Case CStr(.Value)
                        Case "AM"
                            halfDayEvents = eventDelimiter & oneEventString & halfDayEvents
                        Case "PM"
                            halfDayEvents = halfDayEvents & eventDelimiter & oneEventString
                        Case Else
                            fullDayEvents = eventDelimiter & oneEventString & fullDayEvents
                    End Select
                End If
            End If
        End With
    Next oneCell
    fullDayEvents = Mid(fullDayEvents, Len(eventDelimiter) + 1)
    
    halfDayEvents = Mid(halfDayEvents, Len(eventDelimiter) + 1)
    halfDayEvents = fullDayEvents & eventDelimiter & halfDayEvents
    
    If Left(halfDayEvents, Len(eventDelimiter)) = eventDelimiter Then
        halfDayEvents = Mid(halfDayEvents, Len(eventDelimiter) + 1)
    End If
    EventsForDay = halfDayEvents
Exit Function
Halt:
If Err Then EventsForDay = vbNullString
On Error GoTo 0
End Function

UDF's can't automaticaly add sheets, a Change event will be needed.
In the UDF, the variable eventDelimiter is set to vbCr. That line could be changed to vbCr & vbCr.

I'll take a look at your attachment after work. A change event testing if a new sheet is needed and creating it, including the formulas, is doable.

Originally Posted by mikerickson

UDF's can't automaticaly add sheets, a Change event will be needed.
In the UDF, the variable eventDelimiter is set to vbCr. That line could be changed to vbCr & vbCr.

I'll take a look at your attachment after work. A change event testing if a new sheet is needed and creating it, including the formulas, is doable.

Hi Mike,

Now I just want to improve the UDF that allows a line break between each item: Event, Location, so on, and double line break between every event as shown below:

Event: ....
Location: ....
Time: ....
Audiences: ....
Person in charge: .....

Event: ....
Location: ....
Time: ....
Audiences: ....
Person in charge: .....

Event: ....
Location: ....
Time: ....
Audiences: ....
Person in charge: .....



The monthly sheet I will insert and rename it myself. Not necessary to use the button.

Hope you help me little bit more to complete such UDF.

Thanks,

This line, in the middlish of the sub controls the delimiter between items of one event.

oneEventString = oneEventString & HeadersArray(i) & _
   CStr(Application.Intersect(.Cells,dataRange.Columns(columnsReturned(i))).Value) _
   & vbCr

and this line, near the start of the sub, controls the delimiter between different events.

Dim oneEventString As String, eventDelimiter As String: eventDelimiter = vbCr

If you are on a Windows machine, you might need to use vbLF or vbCrLf instead of vbCr.

Thanks for the information!
Good quality site
High page rank
Best paid directory

I don't know.
The file I attached works on my Mac Excel 2004.

Tested on 2007 at work. This introduces another variable lineDelimiter. (There were more of those replacements than I thought.)

Function EventsForDay(dateSought As Double, dataRange As Range, ParamArray columnsReturned() As Variant) As String
    Dim HeadersArray As Variant
    Dim halfDayEvents As String, fullDayEvents As String
    Dim oneEventString As String
    Dim lineDelimiter As String, eventDelimiter As String
    Dim rangeToSearch As Range
    Dim i As Long, oneCell As Range, testLen As Long
    Dim resultstr As String
    
    lineDelimiter = vbLf: eventDelimiter = vbLf
    If Application.OperatingSystem Like "*Mac*" Then
        lineDelimiter = Application.Substitute(lineDelimiter, vbLf, vbCr)
        eventDelimiter = Application.Substitute(eventDelimiter, vbLf, vbCr)
    End If
    On Error GoTo Halt
    With dataRange.Rows(1)
        With .Cells(1, Application.Match(dateSought, .Cells, 0)).EntireColumn
            Set rangeToSearch = Application.Intersect(dataRange, .Cells)
        End With
    End With
    Set rangeToSearch = Application.Intersect(rangeToSearch, rangeToSearch.Offset(1, 0))
    On Error GoTo 0
    
    HeadersArray = columnsReturned
    For i = LBound(columnsReturned) To UBound(columnsReturned)
        If columnsReturned(i) = "time" Then
            HeadersArray(i) = "Time: "
        Else
            HeadersArray(i) = CStr(dataRange.Cells(1, columnsReturned(i)).Value) & ": "
        End If
    Next i
    
    For Each oneCell In rangeToSearch
        With oneCell
            If .Value <> vbNullString Then
            Rem if there is an event, make string describing it
            oneEventString = vbNullString
            For i = LBound(columnsReturned) To UBound(columnsReturned)
                If HeadersArray(i) = "Time: " Then
                    oneEventString = oneEventString & _
                                                    HeadersArray(i)
                                                    
                    Select Case LCase(CStr(.Value))
                        Case "am"
                            oneEventString = oneEventString & _
                                                    "8:30 - 12:00" _
                                                    & lineDelimiter
                        Case "pm"
                            oneEventString = oneEventString & _
                                                    "13:30 - 17:00" _
                                                    & lineDelimiter
                        Case Else
                            oneEventString = oneEventString & _
                                                    "8:30 - 17:00" _
                                                    & lineDelimiter
                    End Select
                Else
                    With .EntireRow
                        oneEventString = oneEventString & _
                                                    HeadersArray(i) & _
                                                    CStr(Application.Intersect(.Cells, dataRange.Columns(columnsReturned(i))).Value) _
                                                    & lineDelimiter
                                                   
                    End With
                End If
            Next i
                If oneEventString <> vbNullString Then
                    Select Case CStr(.Value)
                        Case "AM"
                            halfDayEvents = eventDelimiter & oneEventString & halfDayEvents
                        Case "PM"
                            halfDayEvents = halfDayEvents & eventDelimiter & oneEventString
                        Case Else
                            fullDayEvents = eventDelimiter & oneEventString & fullDayEvents
                    End Select
                End If
            End If
        End With
    Next oneCell
    fullDayEvents = Mid(fullDayEvents, Len(eventDelimiter) + 1)
    
    halfDayEvents = Mid(halfDayEvents, Len(eventDelimiter) + 1)
    halfDayEvents = fullDayEvents & eventDelimiter & halfDayEvents
    
    If Left(halfDayEvents, Len(eventDelimiter)) = eventDelimiter Then
        halfDayEvents = Mid(halfDayEvents, Len(eventDelimiter) + 1)
    End If
    EventsForDay = halfDayEvents
Exit Function
Halt:
If Err Then EventsForDay = vbNullString
On Error GoTo 0
End Function

Your attached file has more than 256 columns. This is causing my Excel 2004 to crash, could you please save a file in 2003 format and upload that file.

The file has a link to EventsForDay.xlam, which I lack, but it looks like its not needed.

Originally Posted by mikerickson

The file has a link to EventsForDay.xlam, which I lack, but it looks like its not needed.

Hi Mike,

The file named EventsForDay.xlam is an addins to run UDF namly EventsForDay in Excel 2007. I forgot not to tell you this.

That file I created by copying your latest VBA code and pasted in VBA Module Editor of Excel 2007, and then saved it as an addins in order to create the UDF. I don't know if such is different from your Excel 2004 on Mac machine. In Excel 2003, it requires to do the same but the file name of the addins is EventsForDay.xla.

However, I find that your previously attached file already included VBA code that allows it to run in any machine without creating an addins in Excel to generate UDF named EventsForDay. So I try to do it like you did in the attached here.

Could you help me review and fix the problems in this file?

Thanks.

I think the attached will do what you want.
The function EventsForDay works with the named range DataRange.

Also, on MasterPlan! C1 there is a button, captioned "Create Sheets".
Pressing the button invokes a userform. Choose from the multi-select list of months and those sheets will be added to the workbook.