Event Calendar from a List with Links and Bars

[msozturk07]

Hi everyone,

I am preparing a calendar that takes information from a event list. Now, I can show events on this calendar by city, date and name. The problems are

1-) If a event has 2 or more days, it is showed on calendar separately. (Like 3 days-event has it's name in every one of B3-B4-B5). I want to make a bar for it (B3-B4-B5 has to be merged and this merged cell has to event name)
2-) There is no links between calendar and list. So, I want to put a link for every event. When you click on the name of event on calendar, it will take you the cell of that event on event list sheet.



Sheet List shows events lists and informantions,

Calendar shows currently calendar I made,

Sheet Need shows what I need at the end.

and this is vba code:

Option Explicit

Sub Calendar()
    Dim S1 As Worksheet, S2 As Worksheet, Tour()
    Dim X As Long, Son As Long, List As Object, Time As Double
    Dim Find_Date As Range, Find_Tour As Range, Y As Date
    
    Time = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("LIST")
    Set S2 = Sheets("CALENDAR")
    
    S2.Range("A2:CH" & S2.Rows.Count).ClearContents
    
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    Tour = S1.Range("C2:C" & Son).Value
    
    Set List = CreateObject("Scripting.Dictionary")
    
    For X = 1 To UBound(Tour)
        List(Tour(X, 1)) = 1
    Next
    
    S2.Range("A2:A" & List.Count + 1) = Application.Transpose(List.Keys)
    
    For X = 2 To Son
        For Y = S1.Cells(X, 4) To S1.Cells(X, 5)
            Set Find_Date = S2.Rows(1).Find(Y)
            If Not Find_Date Is Nothing Then
                Set Find_Tour = S2.Columns(1).Find(S1.Cells(X, 3), , , xlWhole)
                If Not Find_Tour Is Nothing Then
                    If S2.Cells(Find_Tour.Row, Find_Date.Column) = "" Then
                        S2.Cells(Find_Tour.Row, Find_Date.Column) = S1.Cells(X, 2) & " // " & S1.Cells(X, 1) & " PAX"
                    Else
                        S2.Cells(Find_Tour.Row, Find_Date.Column) = S2.Cells(Find_Tour.Row, Find_Date.Column) & Chr(10) & _
                                                                      S1.Cells(X, 2) & " // " & S1.Cells(X, 1) & " PAX"
                    End If
                End If
            End If
        Next
    Next

    Application.ScreenUpdating = True
    
    Set Find_Date = Nothing
    Set Find_Tour = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set List = Nothing
    
    MsgBox "Calendar is updated." & Chr(10) & Chr(10) & _
           "Done in ; " & Format(Timer - Time, "0.00") & " Seconds", vbInformation
End Sub[ATTACH type="full"]5768[/ATTACH][ATTACH]5769[/ATTACH][ATTACH type="full"]5769[/ATTACH]

P.S. : Calendar has been made by using macro, you can find it at macros, named as Calendar

Thank you.