Option Explicit

' requires a reference to the Microsoft Outlook x.0 Object Library
Sub RegisterAppointmentList()
' adds a list of appontments to the Calendar in Outlook
Dim olApp As Outlook.Application
Dim olAppItem As Outlook.AppointmentItem
Dim r As Long
'Dim myrange As String
'myrange = Range("myrange").Value
    DeleteTestAppointments ' deletes previous test appointments
    On Error Resume Next
    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    r = 10 ' first row with appointment data in the active worksheet
    While Len(Cells(r, 1).Formula) > 0
        Set olAppItem = olApp.CreateItem(olAppointmentItem) ' creates a new appointment
        With olAppItem
            ' set default appointment values
            .Start = Now
            .End = Now
            .Subject = "No subject"
            .Location = ""
            .Body = ""
            .ReminderSet = True
            .BusyStatus = olFree
            .RequiredAttendees = ""
            
            
            ' read appointment values from the worksheet
            On Error Resume Next
            .Start = Cells(r, 1).Value + Cells(r, 2).Value
            .End = Cells(r, 8).Value + Cells(r, 3).Value
            .Subject = Cells(r, 4).Value
            .Location = Cells(r, 5).Value
            .Body = varBody
            .ReminderSet = Cells(r, 7).Value
            .BusyStatus = Cells(r, 9).Value
            .RequiredAttendees = Cells(r, 10).Value
            .Categories = "TestAppointment" ' add this to be able to delete the testappointments
            On Error GoTo 0
            .Save ' saves the new appointment to the default folder
        End With
        r = r + 1
    Wend
    Set olAppItem = Nothing
    Set olApp = Nothing
End Sub

Sub DeleteTestAppointments()
' deletes all testappointments in Outlook
Dim olApp As Outlook.Application
Dim OLF As Outlook.MAPIFolder
Dim r As Long, dCount As Long
    On Error Resume Next
    Set olApp = GetObject("", "Outlook.Application")
    On Error GoTo 0
    If olApp Is Nothing Then
        On Error Resume Next
        Set olApp = GetObject("Outlook.Application")
        On Error GoTo 0
        If olApp Is Nothing Then
            MsgBox "Outlook is not available!"
            Exit Sub
        End If
    End If
    Set OLF = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
    dCount = 0
    For r = OLF.Items.Count To 1 Step -1
        If TypeName(OLF.Items(r)) = "AppointmentItem" Then
            If InStr(1, OLF.Items(r).Categories, "TestAppointment", vbTextCompare) = 1 Then
                OLF.Items(r).Delete
                dCount = dCount + 1
            End If
        End If
    Next r
    Set olApp = Nothing
    Set OLF = Nothing
End Sub