Outlook Serientermine werden nicht übertragen

Private Sub CommandButton1_Click()
Dim iRow As Integer
Dim objOL As Outlook.Application
Dim objApt As Outlook.AppointmentItem
Dim i&
On Error Resume Next
Set objOL = New Outlook.Application
i = 1
With Sheets("Data")
.Cells.Delete
For Each objApt In objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar).Items
i = i + 1
.Cells(i, 1) = objApt.Subject
.Cells(i, 2) = objApt.Start
.Cells(i, 3) = objApt.End
.Cells(i, 4) = objApt.Categories
Next
End With
On Error GoTo 0
iRow = Sheets("Data").Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("Data").Range("E2").Formula = "=IF(D2="""","""",IF((C2-B2)*24>=72,(C2-B2)*24-72+( _
_
3*8),IF((C2-B2)*24>=48,(C2-B2)*24-48+(2*8),IF((C2-B2)*24>=24,(C2-B2)*24-24+(1*8),(C2-B2)*24))))" _
Worksheets("Data").Range("E2:E" & iRow).FillDown
Sheets("Data").Cells(1, 1) = "Betreff"
Sheets("Data").Cells(1, 2) = "Start"
Sheets("Data").Cells(1, 3) = "Ende"
Sheets("Data").Cells(1, 4) = "Kategorie"
Sheets("Data").Cells(1, 5) = "Dauer"
Sheets("Analyse").ChartObjects("Diagramm 1").Activate
ActiveChart.PivotLayout.PivotTable.RefreshTable
End Sub