Excel (2013 Germ.Vers) macro to create appointments in Outlook (2013) with runtime error

Hello,

I’ve searched and found may posts about sending appointment from excel sheet to outlook.
This Macro “Add_To_Outlook” was found here in forum and working almost perfect.
One thing is not working that Macro has runtime error 438 by “If olApptSearch = olAppointment”.
If I take this out and run Macro twice I will have duplicated appointments.
I am new to VBA so I don't understand half of this code as I copied from excel forum.
Explanation to sheet “1 source”:
Column B (from B2) containing date, column C (from C2) containing subject. This appointments are all day events “AllDayEvent = True” (no starting and no ending time).
How to adjust this excel macro to create appointments in outlook calendar “Schulung” from excel sheet without duplicates?

Sub Add_To_Outlook()
'!! Reference to Outlook object library required !!
    Dim olAppointment As Outlook.AppointmentItem
    Dim olApptSearch As Outlook.AppointmentItem
    Dim olApp As Outlook.Application
    Dim olFolder As Object
    Dim lngRow As Long, shtSource As Worksheet
    Dim NS As Outlook.Namespace
    Dim colItems As Outlook.Items
    Dim Appfound As Boolean
    Dim UseDate As Date

    'Get reference to MS Outlook
    On Error Resume Next
    Set olApp = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
        On Error GoTo 0
    End If
 
    Dim MyCal As String
    MyCal = "Schulung"   ' change your calendar name here
    Set NS = olApp.GetNamespace("MAPI")
    Set olFolder = NS.GetDefaultFolder(olFolderCalendar)
    On Error Resume Next
    Set olFolder = olFolder.Folders(MyCal)
    'Set olFolder = NS.GetDefaultFolder(9) 'for Calender on my computer
    On Error GoTo 0
    Set shtSource = ActiveSheet

    For lngRow = 2 To shtSource.Cells(Rows.Count, 2).End(xlUp).Row
        Appfound = False
        Set olAppointment = olFolder.Items.Add
        UseDate = shtSource.Cells(lngRow, 2).Value
        With olAppointment
            .Subject = "" & shtSource.Cells(lngRow, 3)
            .Start = UseDate
            .AllDayEvent = True
            .ReminderSet = True
            Set colItems = olFolder.Items
            
            For Each olApptSearch In colItems
               'If olApptSearch = olAppointment Then Appfound = True '==> here comes "Runtime Error 438"
            Next
            If Appfound = False Then
                .Save
            Else
                MsgBox "Appointment '" & .Subject & "' already exists. Not saved."
            End If
        End With

        Set olAppointment = Nothing
    Next lngRow
End Sub

Would appreciate any help you can give me on this.

Many thanks in advance
Excelianer

Hi everyone,
I hope someone can help me.... how to adjust in posted code above “If olApptSearch = olAppointment Then Appfound = True” to run it whihout entering duplicate appointmnts o Outlook. My Office version is 2013 German version.

Do you have similar or other suggestion?

Thanks in advance for your helps...

.... *“If olApptSearch = olAppointment Then Appfound = True”...
Did any one try to run this makro?
For any help or advices I am very thankfull