Hi,

Suprisingly this stayed unanswered !

The procedure below creates appointment, picking subject in range A2:A... and picking start time from next column.

Sub MS_OL_Appointment_Creation()
Dim objOutlook As Object 'As Outlook.Application
Dim olAppt As Object 'Outlook.AppointmentItem
Dim NS 'As Outlook.Namespace
Dim colItems 'As Outlook.Items
Dim olApptSearch 'As Outlook.AppointmentItem
Dim r As Long, sSubject As String, sBody As String
Dim dStartTime As Date, dDuration As Double
Dim sSearch As String, bOLOpen As Boolean

Dim cl As Range

Dim olApp As Object
Dim olNs As Object
Const olFldrCalendar As Long = 9
Dim olApt As Object
Dim bAllDayEvent As Boolean
Dim bReminderSet As Boolean
bAllDayEvent = True
bReminderSet = False
dDuration = 30

'' Get the MS Outlook opened instance or open one.
'On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
bOLOpen = True
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
bOLOpen = False
End If

'' Get Namespace
Set NS = objOutlook.GetNamespace("MAPI")

'' Get default calendar items
Set colItems = NS.GetDefaultFolder(olFolderCalendar).Items

For Each cl In Range("A2", Range("A" & Cells.Rows.Count).End(xlUp))
dStartTime = cl.Offset(, 1) & " 00:00"
sSubject = cl.Text
sBody = "this is the appointment description : " & cl.Offset(, 2)

'' Search for already existing appointments comparing subject and date fields.
sSearch = "[Subject] = " & sQuote(sSubject) '& " and [Start] = " & sQuote(dSartTime)
Set olApptSearch = colItems.Find(sSearch)

If olApptSearch Is Nothing Then
Set olAppt = objOutlook.CreateItem(olAppointmentItem)
olAppt.Subject = sSubject
olAppt.Body = sBody
olAppt.Start = dStartTime
olAppt.AllDayEvent = bAllDayEvent
olAppt.ReminderSet = true
'olAppt.Duration = dDuration
olAppt.Save 'Close olSave
Else
Stop
End If

Debug.Print cl.Address
NextRow:
Next cl

If bOLOpen = False Then objOutlook.Quit

End Sub
Function sQuote(TheText) As String
sQuote = "'" & TheText & "'"
End Function