Sub macro1()
Dim r As Integer, x As Integer, y As Integer, lk As Integer
With Sheets(2)
.Columns("a:k").Delete
Application.ScreenUpdating = False
.Cells(1, 10) = "Milestone_Date": .Cells(1, 11) = "Milestone_Type"
.Range("j1:k1").Interior.ColorIndex = 3
Sheets(1).Range("a1:i1").Copy .Range("a1:i1")
End With
r = 2: y = 2
Do Until IsEmpty(Sheets(1).Cells(r, 1))
With Sheets(1)
lk = .Cells(r, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(r, 1), .Cells(r, 9)).Copy Sheets(2).Cells(y, 1)
.Range(.Cells(r, 10), .Cells(r, lk)).Copy
End With
With Sheets(2)
.Cells(y, 10).PasteSpecial Transpose:=True
.Range(.Cells(y, 1), .Cells(y + lk - 10, 9)).FillDown
For x = 1 To lk - 9
With .Cells(y, 11)
.Value = "Milestone " & x
.Interior.ColorIndex = 23
End With
y = y + 1
Next x
.Columns("a:k").AutoFit
End With
r = r + 1
Loop
With Application
.CutCopyMode = False
.Goto reference:=Range("a1")
.ScreenUpdating = True
End With
End Sub