Below is a macro that works quite well, but I need to make a bit of a change to it. This macro takes a line of information from Excel and creates a task in MicroSoft Outlook. It also ensures that the same task is only entered once.
I have not quite decided yet, but I want the tasks that this creates in outlook to either be assigned to a certain person assigned in the macro OR to have the ability to assign each task to someone differently via a column where each row is a separate item. The Excel spreadsheet will end up being saved on our network drive and not on a local drive so need to be able to tell the macro who to assign the task to.
thanks
Brent
Sub CreateTask()
Dim olApp As New Outlook.Application
Dim olName As Outlook.Namespace
Dim olFolder As Outlook.Folder
Dim olTasks As Outlook.Items
Dim olNewTask As Outlook.TaskItem
Dim strSubject As String
Dim strDate As String
Dim strBody As String
Dim reminderdate As String
Dim ws As Worksheet
Dim LR As Long
Dim i As Long
Set ws = Worksheets("sheet1") 'sheet where dates are
Set wg = Worksheets("sheet2") 'sheet where data is calculated
LR = ws.Range("D1").End(xlDown).Row 'get row for last cell in column D with value
Set olName = olApp.GetNamespace("MAPI")
Set olFolder = olName.GetDefaultFolder(olFolderTasks)
Set olTasks = olFolder.Items
For i = 2 To LR 'assuming the rows have headers, so loop starts on row 2
strSubject = ws.Range("D" & i) 'takes subject from column D
strDate = ws.Range("C" & i) 'takes date from column C
strBody = ws.Range("E" & i) 'takes text from column E and adds it as Body
reminderdate = wg.Range("D" & i) 'Takes date from column D and enters it as the reminder date
Set olNewTask = olTasks.Add(olTaskItem)
'delete task if it exists
'an error is generated if task doesn't exist
On Error Resume Next
olTasks.Item (strSubject)
If Err.Number = 0 Then
olTasks.Item(strSubject).Delete
End If
On Error GoTo 0
'create new task
With olNewTask
.Subject = strSubject
.Status = olTaskInProgress
.Importance = olImportanceNormal
.DueDate = DateValue(strDate)
.Body = strBody
.ReminderSet = True
.ReminderTime = reminderdate
.TotalWork = 40
.ActualWork = 20
.Save
End With
Next i
End Sub
I have not quite decided yet, but I want the tasks that this creates in outlook to either be assigned to a certain person assigned in the macro OR to have the ability to assign each task to someone differently via a column where each row is a separate item. The Excel spreadsheet will end up being saved on our network drive and not on a local drive so need to be able to tell the macro who to assign the task to.
thanks
Brent
Sub CreateTask()
Dim olApp As New Outlook.Application
Dim olName As Outlook.Namespace
Dim olFolder As Outlook.Folder
Dim olTasks As Outlook.Items
Dim olNewTask As Outlook.TaskItem
Dim strSubject As String
Dim strDate As String
Dim strBody As String
Dim reminderdate As String
Dim ws As Worksheet
Dim LR As Long
Dim i As Long
Set ws = Worksheets("sheet1") 'sheet where dates are
Set wg = Worksheets("sheet2") 'sheet where data is calculated
LR = ws.Range("D1").End(xlDown).Row 'get row for last cell in column D with value
Set olName = olApp.GetNamespace("MAPI")
Set olFolder = olName.GetDefaultFolder(olFolderTasks)
Set olTasks = olFolder.Items
For i = 2 To LR 'assuming the rows have headers, so loop starts on row 2
strSubject = ws.Range("D" & i) 'takes subject from column D
strDate = ws.Range("C" & i) 'takes date from column C
strBody = ws.Range("E" & i) 'takes text from column E and adds it as Body
reminderdate = wg.Range("D" & i) 'Takes date from column D and enters it as the reminder date
Set olNewTask = olTasks.Add(olTaskItem)
'delete task if it exists
'an error is generated if task doesn't exist
On Error Resume Next
olTasks.Item (strSubject)
If Err.Number = 0 Then
olTasks.Item(strSubject).Delete
End If
On Error GoTo 0
'create new task
With olNewTask
.Subject = strSubject
.Status = olTaskInProgress
.Importance = olImportanceNormal
.DueDate = DateValue(strDate)
.Body = strBody
.ReminderSet = True
.ReminderTime = reminderdate
.TotalWork = 40
.ActualWork = 20
.Save
End With
Next i
End Sub