Outlook Termine auslesen und übertragen

Sub FindTermine()
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
Dim olNS As Outlook.NameSpace: Set olNS = olApp.GetNamespace("MAPI")
Dim olApt As Object
Dim NextRow As Long
Dim FromDate As Date
Dim ToDate As Date
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Import")
Dim myAppointments As Outlook.Items
Dim objOwner As Object: Set objOwner = olNS.CreateRecipient(AvailableCals.Value)
FromDate = CDate(MonBox.Value)
ToDate = CDate(EndDate.Caption)
On Error Resume Next
If Err.Number > 0 Then Set olApp = CreateObject("Outlook.Application")
objOwner.Resolve
If objOwner.Resolved Then
Set myAppointments = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar).Items
End If
myAppointments.Sort "[Start]"
myAppointments.IncludeRecurrences = True
Set olApt = myAppointments.Find("[Start] >= """ & _
FromDate & """ and [Start]  "Nothing"
MsgBox objOwner & " - " & olApt.Subject & " - " & CDate(olApt.Start) & " - " & CDate(olApt.End) _
_
& " - " & Format(olApt.End - olApt.Start, "0.00") & " - " & olApt.Location
Set olApt = myAppointments.FindNext
Wend
End Sub

While TypeName(olApt)  "Nothing"

NextRow = 2

With Sheets("Import")

.Range("A2:F199").Value = ""

.Range("A1:F1").Value = Array("Besitzer", "Termin", "Beginn", "Ende", "Dauer", "Ort")


For Each olApt In myAppointments.Items

If (olApt.Start >= FromDate And olApt.Start 
.Cells(NextRow, "A").Value = objOwner

.Cells(NextRow, "B").Value = olApt.Subject

.Cells(NextRow, "C").Value = CDate(olApt.Start)

.Cells(NextRow, "D").Value = CDate(olApt.End)

.Cells(NextRow, "D").NumberFormat = "HH:MM"

.Cells(NextRow, "E").Value = olApt.End - olApt.Start

.Cells(NextRow, "E").NumberFormat = "HH:MM"

.Cells(NextRow, "F").Value = olApt.Location

NextRow = NextRow + 1

Else

End If

Next olApt

On Error GoTo 0

.Columns.AutoFit

End With

Set olApt = Nothing

Set myAppointments = Nothing

Set olNS = Nothing

Set olApp = Nothing

Wend

cleanExit:

Application.ScreenUpdating = True

Exit Sub

ErrHand:

'Add error handler

Resume cleanExit

End Sub