Monthly Event Schedule (format like that)

Originally Posted by mikerickson

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

Hi Mike,

Thank you so much for your kind patience to help me. I've done like your guidance with new code above in Excel 2007 on Windows machine, but it seems there are still certain problems that bring no result. I don't know much VBA to solve myself.

I prefer Excel 2007 to Excel 2003, because there are enough columns in Excel 2007 to enable me to make a plan for the whole year with 365 days.

Could you please take a look at the attached file that I did and help me make it work?

Many thanks.