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.
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.
Code:
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
Last edited: