folgenden VBA-Code habe ich, der grundsätzlich auch funktioniert und die Termine inkl. Kategorien nach Excel überträgt. Leider fehlen einige aktuelle Termine, scheinen alles Serientermine zu sein. Warum werden diese nicht übertragen. Hat jemand eine Idee, wie es klappen könnte und einen Vorschlag für einen neuen Code?
Danke vorab.
VG
Daniel
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