Generated Project Portfolio Timeline - excel

Question

I have a list of Projects:
Project A
Project B
Project C
and milestones for each project with a date for the milestone:
Project A Milestone 1 01/01/2015
Project A Milestone 2 01/02/2015
Project A Milestone 3 01/03/2015
Project B Milestone 1 01/04/2015
I am looking to generate a type of timeline for all of the projects in one sheet, with milestones displayed in their respective month.
Column A would have the list of projects and row 1 have months, then to display the milestone where the month and project match.
So far I have been able to extract the list of projects using a macro:
Sub UniqueList()
Dim rListPaste As Range
Dim iReply As Integer
On Error Resume Next
Set rListPaste = Application.InputBox _
(Prompt:="Please select the destination cell", Type:=8)
If rListPaste Is Nothing Then
iReply = MsgBox("No range nominated," _
& " terminate", vbYesNo + vbQuestion)
If iReply = vbYes Then Exit Sub
End If
Range("A1", Range("A65536").End(xlUp)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=rListPaste.Cells(1, 1), Unique:=True
End Sub
After this I am pretty stuck. Any advice would be greatly appreciated.

Answer 1

I've done a similar setup to develop a milestone chart based on the current week. I've modified it to match your requirements:
Sub CreateMilestoneChart()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim LastRow As Long
Dim i As Long, j As Long
Dim FirstMonth As Long
Dim FirstYear As Long
Dim LastMonth As Long
Dim LastYear As Long
Dim curRange As Range
Set ws1 = Worksheets("Project List")
Set ws2 = Worksheets("Milestone Chart")
Application.ScreenUpdating = False
LastRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row
'-----You will want to modify or remove these lines once-----
'-----you get the sheet formatted the way you want-----------
ws2.Cells.Clear
ws2.Range("A1").Value = "Milestone Chart"
ws2.Range("A2").Value = "Generated on " & Date
ws2.Range("A3").Value = "Month:"
ws2.Range("A3").HorizontalAlignment = xlRight
'------------------------------------------------------------
ws1.Range("A1:C" & LastRow).Copy
ws2.Range("A4").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
LastRow = LastRow + 3
For i = 4 To LastRow
ws2.Cells(i, 1).Value = ws2.Cells(i, 1).Value & " " & ws2.Cells(i, 2).Value
Next i
ws2.Range("A4:A" & LastRow).HorizontalAlignment = xlRight
ws2.Range("B4:B" & LastRow).Delete Shift:=xlToLeft
With ws2.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B4:B" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A4:B" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
FirstMonth = DatePart("m", ws2.Range("B4").Value)
FirstYear = DatePart("yyyy", ws2.Range("B4").Value)
LastMonth = DatePart("m", ws2.Range("B" & LastRow).Value)
LastYear = DatePart("yyyy", ws2.Range("B" & LastRow).Value)
ws2.Range("B3").Value = CDate(FirstMonth & "/" & FirstYear)
Set curRange = ws2.Range("B3")
i = 1
Do Until DatePart("m", curRange.Value) = LastMonth And DatePart("yyyy", curRange.Value) = LastYear
Set curRange = ws2.Cells(3, i + 2)
curRange.Value = DateAdd("m", 1, ws2.Cells(3, i + 1).Value)
i = i + 1
Loop
ws2.Cells(3, i + 2).Value = DateAdd("m", 1, ws2.Cells(3, i + 1).Value)
For i = 4 To LastRow
j = 2
Do Until ws2.Cells(i, j).Value >= ws2.Cells(3, j).Value And ws2.Cells(i, j).Value < ws2.Cells(3, j + 1).Value
ws2.Cells(i, 2).Insert Shift:=xlToRight
ws2.Cells(i, 2).Value = "'-----------------"
j = j + 1
Loop
Next i
Application.ScreenUpdating = True
End Sub
It's not very clean by any means, but it will work. You will need to modify it to fit your needs.