Running Auto-Fill Calendar Multiple Names, Dates, & Statuses

[mmalkasi]

I am trying to create a running calendar for a team. There are 7 team members (Jeremy, Ben, Nate, Matt, Harry, Logan, Team 7) dates, and 3 statuses (Training, Deployed, Leave) I made two sheets: 1st with the raw data (Date, Name, Status) and the second sheet with the yearly calendar. I want the calendar to auto populate with the team member name and the type of status in the corresponding dates. So lets say on the raw data sheet I set the date, name, and status as:

1 Sept. 2018-10 Sept 2018, Jeremy, Leave
28 Aug. 2018 - 5 Sept. 2018, Ben, Training
19 Sept. 2018 - 30 Sept. 2018, Team 7, Deployed

I need all of the information to be filled in on the calendar, even the data that's overlapping in dates. So for the first two examples, Jeremy and Ben's names should show on September 1-5 as on Leave and Training.

I tried using a pivot calendar but just made the whole thing just way too complicated and I wasn't able to have it display more than 1 team name for each day. Can anyone help with this?

 

[MickG]

Try this:-
NB:- Assuming you data starts "A2" on sheet1, then this code will produce a Calendar in sheet2 starting "A2", and consisting of dates from Min Date to Max date in sheet1, with the corresponding names/Status in the subsequent columns.

[COLOR="Navy"]Sub[/COLOR] MG29Aug56
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, oMin [COLOR="Navy"]As[/COLOR] Date, oMax [COLOR="Navy"]As[/COLOR] Date, Sp [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dt [COLOR="Navy"]As[/COLOR] Date, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Dic [COLOR="Navy"]As[/COLOR] Object, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
oMin = "1/1/3000"
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Sp = Split(Dn.Value, "-")
    [COLOR="Navy"]For[/COLOR] n = 0 To 1
        [COLOR="Navy"]If[/COLOR] (Sp(n)) < oMin [COLOR="Navy"]Then[/COLOR] oMin = Sp(n)
        [COLOR="Navy"]If[/COLOR] (Sp(n)) > oMax [COLOR="Navy"]Then[/COLOR] oMax = Sp(n)
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
[COLOR="Navy"]For[/COLOR] Dt = oMin To oMax
    c = c + 1
        [COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
            .Cells(c + 1, "A") = Dt
        [COLOR="Navy"]End[/COLOR] With
        Dic(Dt) = c + 1
[COLOR="Navy"]Next[/COLOR] Dt
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Ac = Ac + 1
    Sp = Split(Dn.Value, "-")
    [COLOR="Navy"]For[/COLOR] Dt = Sp(0) To Sp(1)
        [COLOR="Navy"]With[/COLOR] Sheets("sheet2")
            .Cells(Dic(Dt), Ac + 1) = Dn.Offset(, 1).Value & "/" & Dn.Offset(, 2).Value
        [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]Next[/COLOR] Dt
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[mmalkasi]

Thanks Mick for replying! Your macro worked beautifully to create a list of dates for each team member and what their status is for a specific time frame. But I still need the info in an actual calendar. I attached a screenshot of what I mean. I've had a lot of trouble putting the names and statuses as multiple entries for a single date. I tried using an indexmatch formula too but for some reason I'm just not able to make it work.

 

[MickG]

Try this code in sheet2.
It should create your Calendar and fill it with Names and Status from sheet1 based on Dates.

[COLOR=navy]Sub[/COLOR] MG30Aug14
[COLOR=navy]Dim[/COLOR] mDay [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] col [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Rw [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] mMax [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Mth [COLOR=navy]As[/COLOR] [COLOR=navy]Long[/COLOR]
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, n [COLOR=navy]As[/COLOR] [COLOR=navy]Long,[/COLOR] Dic [COLOR=navy]As[/COLOR] Object
[COLOR=navy]Dim[/COLOR] Sp [COLOR=navy]As[/COLOR] Variant, Dt [COLOR=navy]As[/COLOR] Date
[COLOR=navy]With[/COLOR] Columns("A:G")
    .ClearContents
    .HorizontalAlignment = xlCenter
[COLOR=navy]End[/COLOR] With
[COLOR=navy]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
   Rw = 2
   col = 8
[COLOR=navy]For[/COLOR] Mth = 1 To 12
    [COLOR=navy]With[/COLOR] Cells(Rw, 1)
        .NumberFormat = "@"
        .Value = MonthName(Mth, True) & "  " & Year(Now)
        .Interior.Color = vbGreen 
        .Font.Size = 12
        Rw = Rw + 1
    [COLOR=navy]End[/COLOR] With
        [COLOR=navy]For[/COLOR] mDay = 1 To 7
            [COLOR=navy]With[/COLOR] Cells(Rw, mDay)
                .Value = WeekdayName(mDay, True, 1)
                .Interior.ColorIndex = 20
                .Font.Size = 12
            [COLOR=navy]End[/COLOR] With
       [COLOR=navy]Next[/COLOR] mDay
Rw = Rw + 1
[COLOR=navy]Select[/COLOR] [COLOR=navy]Case[/COLOR] Mth
    [COLOR=navy]Case[/COLOR] 2: mMax = IIf(Year(Now) Mod 4 = 0, 29, 28)
    [COLOR=navy]Case[/COLOR] 4, 6, 9, 11: mMax = 30
    [COLOR=navy]Case[/COLOR] Else: mMax = 31
[COLOR=navy]End[/COLOR] Select
[COLOR=navy]For[/COLOR] mDay = 1 To 31
    col = Weekday(DateSerial(Year(Now), Mth, mDay))
    [COLOR=navy]With[/COLOR] Cells(Rw, col)
        .Value = mDay
        .NumberFormat = "0"
    [COLOR=navy]End[/COLOR] With
     [COLOR=navy]Set[/COLOR] Dic(DateSerial(Year(Now), Mth, mDay)) = Cells(Rw, col)
            Rw = Rw + IIf(col Mod 7 = 0, 1, 0)
                [COLOR=navy]If[/COLOR] mDay = mMax [COLOR=navy]Then[/COLOR] [COLOR=navy]Exit[/COLOR] For
[COLOR=navy]Next[/COLOR] mDay
Rw = Rw + 2
[COLOR=navy]Next[/COLOR] Mth
Range("A2").Resize(Rw, 7).Borders.Weight = 2
[COLOR=navy]With[/COLOR] Sheets("Sheet1")
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    Sp = Split(Dn.Value, "-")
    [COLOR=navy]For[/COLOR] Dt = Sp(0) To Sp(1)
            Dic(Dt).Value = Dic(Dt).Value & vbLf & Dn.Offset(, 1).Value _
            & "/" & Dn.Offset(, 2).Value
    [COLOR=navy]Next[/COLOR] Dt
[COLOR=navy]Next[/COLOR] Dn
[COLOR=navy]End[/COLOR] With
[COLOR=navy]With[/COLOR] Columns("A:G")
     .ColumnWidth = 20
     .Rows.AutoFit
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]

Regards Mick