Sub import()
Dim OutApp As Object
Dim apptOutApp As Object
Dim objFolder As Object
Dim objNS As Object
Range("A2").Select
Do Until ActiveCell.Value = ""
Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1)
With apptOutApp
.Start = Format(ActiveCell.Value, "dd/mm/yyyy") & _
" " & Format(ActiveCell.Offset(0, 1).Value, "hh:mm")
.Subject = ActiveCell.Offset(0, 2).Value
.Body = ""
.Categories = ActiveCell.Offset(0, 4).Value
.Duration = "120"
.ReminderMinutesBeforeStart = 20160
.ReminderPlaySound = True
.ReminderSet = True
.Save
End With
ActiveCell.Offset(1, 0).Select
Set apptOutApp = Nothing
Set OutApp = Nothing
Loop
MsgBox "Termine wurden in Outlook eingetragen!"
End Sub