Sub ExportToOutlook()
Dim OL As Outlook.Application
Dim olAppt As TaskItem
Dim NS As Outlook.Namespace
Dim colItems As Outlook.Items
Dim olApptSearch As TaskItem
Dim r As Long, sSubject As String, sBody As String, sCateg As String
Dim dStartDate As Date, dDueDate As Date
Dim sSearch As String, bOLOpen As Boolean
Dim dl&
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
bOLOpen = True
If OL Is Nothing Then
Set OL = CreateObject("Outlook.Application")
bOLOpen = False
End If
Set NS = OL.GetNamespace("MAPI")
Set colItems = NS.GetDefaultFolder(olFolderTasks).Items
dl = Cells(Rows.Count, "B").End(xlUp).Row
For r = 4 To dl
sSubject = Cells(r, "B").Value
dStartDate = Cells(r, "C").Value
sCateg = Cells(r, "D").Value
sBody = Cells(r, "E").Value & Chr(10) & Cells(r, "F").Value & Chr(10) _
& Cells(r, "G").Value & Chr(10) & Cells(r, "H").Value
sSearch = "[Subject] = " & sQuote(sSubject)
Set olApptSearch = colItems.Find(sSearch)
If olApptSearch Is Nothing Then
Set olAppt = OL.CreateItem(olTaskItem)
olAppt.Subject = sSubject
olAppt.Categories = sCateg
olAppt.StartDate = dStartDate
olAppt.Body = sBody
olAppt.Close olSave
End If
Next r
If bOLOpen = False Then OL.Quit
End Sub