Outlook Kalender Kategorie exportieren

Sub TermineVonExcelNachOutlookÜbernehmen()
Dim objOutlook As Outlook.Application
Dim apptOutlook As Outlook.AppointmentItem
Set objOutlook = CreateObject("Outlook.Application")
Range("A2").Select
Do Until ActiveCell.Value = ""
Set apptOutlook = objOutlook.CreateItem(olAppointmentItem)
With apptOutlook
.Subject = ActiveCell.Value
.Body = ActiveCell.Offset(0, 1).Value
.Location = ActiveCell.Offset(0, 2).Value
.Start = ActiveCell.Offset(0, 3).Value
.RequiredAttendees = ActiveCell.Offset(0, 5).Value
.ReminderMinutesBeforeStart = 1080
        .Categories = ActiveCell.Offset(0, 6).Value

.AllDayEvent = True
.ReminderPlaySound = True
.ReminderSet = True
.Save
End With
ActiveCell.Offset(1, 0).Select
Loop
MsgBox "Termine an Outlook übertragen!"
Set apptOutlook = Nothing
Set objOutlook = Nothing
End Sub