Excel Termine nach Outlook ohne Duplikate

Sub Excel_Termin_nach_Outlook_Ohne_Duplikate()
Dim wksSheet As Worksheet
Dim objFolder As Object
Dim objOutApp As Object
Dim objTermin As Object
Dim lngRow As Long
On Error GoTo Fin
Set wksSheet = ThisWorkbook.Worksheets("Tabelle3") ' Anpassen!!!
'Set objOutApp = CreateObject("Outlook.Application")
'9 = olFolderCalendar
Set objFolder = objOutApp.GetNamespace("MAPI").GetDefaultFolder(9)
For lngRow = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Not fncPointExist(objFolder, wksSheet.Cells(lngRow, 2).Value) Then
Set objTermin = objOutApp.CreateItem(1)
With objTermin
.AllDayEvent = True
.Start = Format(wksSheet.Cells(lngRow, 1).Value _
+ 0, "dd.mm.yyyy") '& " 08:00"
.Subject = wksSheet.Cells(lngRow, 2).Value
.Save
End With
Set objTermin = Nothing
End If
Next lngRow
Fin:
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & " " & Err.Description
Set objFolder = Nothing
Set objTermin = Nothing
Set objOutApp = Nothing
If Err.Number = 0 Then MsgBox "Termine nach Outlook übertragen!"
End Sub
Private Function fncPointExist(ByVal objTMP As Object, _
ByVal strSubject As String) As Boolean
Dim objItem As Object
For Each objItem In objTMP.Items
If objItem.Subject = strSubject Then fncPointExist = True
Next
End Function