Macro to Update Outlook Task from Excel Spreadsheet

[suemahood]

Hello,
I have a macro that creates tasks in Outlook 2007 from Excel 2007. What it doesn't do is update task start and due dates on existing outlook tasks if the user changes them in excel. Would be grateful for any advice on how I can fix this. The reason the ability to update is needed is that this is for a workflow planning tool and my priorities are often interupted and need revision. Tasks will always remain the same - it's just the dates that need to be able to change.

Option Explicit
Sub AddToOutlook()
    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
    Dim dStartDate As Date, dDueDate As Date
    Dim sSearch As String, bOLOpen As Boolean
    Dim s As Worksheet
    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
    For r = 9 To 200
        If Len(Sheet1.Cells(r, 1).Value) = 0 Then GoTo NextRow
        sSubject = Sheet1.Cells(r, 8).Value
        dStartDate = Sheet1.Cells(r, 1).Value
        dDueDate = Sheet1.Cells(r, 3).Value
        sSearch = "[Subject] = " & sQuote(sSubject)
        Set olApptSearch = colItems.Find(sSearch)
        If olApptSearch Is Nothing Then
            Set olAppt = OL.CreateItem(olTaskItem)
            olAppt.Subject = sSubject
            olAppt.StartDate = dStartDate
            olAppt.Reminder
            olAppt.DueDate = dDueDate
            olAppt.Save
        End If
NextRow:
    Next r
    If bOLOpen = False Then OL.Quit
End Sub
Function sQuote(sTextToQuote)
    sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function

 

[suemahood]

Okay, so I have got the code to work now after a fashion, but I would really love some advice on how to make it run better. Currently if I click a button in excel that the code is attached to, and the existing outlook tasks will update...but I have to run the code twice to get the correct due dates. Could you whizzes out there please take a look at my code and let me know if you can spot the reason why this is happening. I'm stumped.

Option Explicit
Sub AddToOutlook()
    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
    Dim dStartDate As Date, dDueDate As Date
    Dim sSearch As String, bOLOpen As Boolean
    Dim s As Worksheet
    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
    For r = 12 To 200
        If Len(Sheet1.Cells(r, 1).Value) = 0 Then GoTo NextRow
        sSubject = Sheet1.Cells(r, 8).Value
        dStartDate = Sheet1.Cells(r, 1).Value
        dDueDate = Sheet1.Cells(r, 3).Value
        sSearch = "[Subject] = " & sQuote(sSubject)
        Set olApptSearch = colItems.Find(sSearch)
        If olApptSearch Is Nothing Then
            Set olAppt = OL.CreateItem(olTaskItem)
            olAppt.Subject = sSubject
            olAppt.StartDate = dStartDate
            olAppt.Reminder
            olAppt.DueDate = dDueDate
        ElseIf Not olApptSearch Is Nothing Then
            For Each olAppt In colItems
            If olAppt.Subject = sSubject Then
            olAppt.DueDate = dDueDate
            olAppt.StartDate = dStartDate
            olAppt.Save
            End If
        Next olAppt
        End If
NextRow:
    Next r
    If bOLOpen = False Then OL.Quit
End Sub
Function sQuote(sTextToQuote)
    sQuote = Chr(34) & sTextToQuote & Chr(34)
End Function