Sub Outlook_Termine()
Dim ns As Outlook.Namespace
Dim myfolder As Outlook.Folder
Dim mysubfolder As Outlook.Folder
Set ns = GetObject("", "Outlook.Application").GetNamespace("MAPI")
Set myfolder = ns.GetDefaultFolder(9).Folders("Fewo-Belegung")
Worksheets("Laufendes Jahr").Activate
LetzteZeile = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
Z = Range("Abgeschlossen").Rows.Count + 2
y = Range("Bevorstehend").Rows.Count
LetzteZeileBevorstehend = LetzteZeile - Z - 2
Dim oTermin As Outlook.AppointmentItem
Set oTermin = myfolder.Items.Add(olAppointmentItem)
For i = 14 To LetzteZeileBevorstehend
With oTermin
.Display
.Subject = Range("B" & i).Value
.Start = Range("F" & i).Value
.End = Range("G" & i).Value
.AllDayEvent = True
.ReminderSet = False
.Save
End With
Next
Set oTermin = Nothing
End Sub