How do I get this to look at a date and loop down all the info?

[Pasty]

I have some code that fires of actions to peoples tasks to remind them that
they have bits and bobs coming out - what I want it to do is go down the
spreadsheet (its around 296 rows and has merged cells for some bits) and see
if there is a month or less until the action is due and then send it but it
is giving me a headache.

The code that works for the initial task sending is as follows:

Sub Create_Task()

Dim olApp As Outlook.Application
Dim olTask As Outlook.TaskItem
Dim Subject As String
Dim Body As String
Dim wbBook As Workbook
Dim wsMain As Worksheet

Set wbBook = ThisWorkbook
Set wsMain = wbBook.Worksheets("Risk By Function")

Set olApp = New Outlook.Application
Set olTask = olApp.CreateItem(3)

With wsMain
Subject = "Non-Financial Risk Actions due"
Body = "Action due:" & vbCrLf & .Cells(5, 21).Value
Body2 = "Due date:" & vbCrLf & .Cells(5, 22).Value
End With

Application.ScreenUpdating = False

'With olTask
'.Subject = "This is the title"
'.Body = "This is the body"
'You need to change to Your own dateformat.
'.StartDate = "2002-09-11"
'.DueDate = "2002-09-14"
'.Status = olTaskWaiting
'.Importance = olImportanceHigh
'.ReminderPlaySound = True
'.Companies = "XL-Dennis"
'.Save
'End With
On Error GoTo Error_Handling

With olTask
..Subject = Subject
..Body = Body
..StartDate = Date
..DueDate = "28/04/2007"
..Importance = olImportanceHigh
..Save
..Recipients.Add ("Ruth Brink")
..Assign
..Send
End With

Set olTask = Nothing

Set olApp = Nothing

Application.ScreenUpdating = True

MsgBox "The task-list updated successfully.", vbInformation

Error_Handling:
If Err.Number = 429 And olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume
End If


End Sub

Any help with this would be greatly appreciated.

Regards

 

[Bernie Deitrick]

Pasty,

The general idea is to loop through your values checking for the condition. For the macro below,
I've assumed that the dates are in column V, and that column W is free to put in a flag so that you
won't duplicate tasks. Also, your recipient is poor Ruth every time, so you may want to change that
part.

HTH,
Bernie
MS Excel MVP


Sub Create_Tasks()

Dim olApp As Outlook.Application
Dim olTask As Outlook.TaskItem
Dim Subject As String
Dim Body As String
Dim wbBook As Workbook
Dim wsMain As Worksheet
Dim myCell As Range
Dim myR As Range


Set wbBook = ThisWorkbook
Set wsMain = wbBook.Worksheets("Risk By Function")
Set myR = wsMain.Range("V5:V500")

Set olApp = New Outlook.Application

For Each myCell In myR
If myCell.Value <> "" And _
myCell.Value <= Now + 30 And _
myCell(1, 2).Value <> "Notified" Then

Set olTask = olApp.CreateItem(3)

With wsMain
Subject = "Non-Financial Risk Actions due"
Body = "Action due:" & vbCrLf & .Cells(myCell.Row, 21).Value
Body2 = "Due date:" & vbCrLf & .Cells(myCell.Row, 22).Value
End With

Application.ScreenUpdating = False

On Error GoTo Error_Handling

With olTask
.Subject = Subject
.Body = Body
.StartDate = Date
.DueDate = wsMain.Cells(myCell.Row, 22).Text
.Importance = olImportanceHigh
.Save
.Recipients.Add ("Ruth Brink")
.Assign
.Send
End With

Set olTask = Nothing

Set olApp = Nothing

Application.ScreenUpdating = True

' MsgBox "The task-list updated successfully.", vbInformation

Error_Handling:
If Err.Number = 429 And olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume
End If

myCell(1, 2).Value = "Notified"
End If
Next myCell

End Sub

 

[Pasty]

I tried this out and it gives me lots of different errors one after the other
e.g. Error No: -2114961403; Description: and when I press okay it brings up
another one with a different number so I have to exit the spreadsheet with
Task Manager.

 

[Bernie Deitrick]

Pasty,

The looping code worked for me in my testing.

Unfortunately, I assumed that your statement "The code that works for the initial task sending is as
follows:" meant that the code you posted actually worked. But it is your initial code that is
throwing the error.

There are two problems: you don't have a way for the code to get around the error handler, and you
don't display the description of the error - use this in place of your Error_Handling:

GoTo NoErrors:
Error_Handling:
If Err.Number = 429 And olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume
End If

NoErrors:


Also, I used a working email address in the recipients.add line, and that worked for me

.Recipients.Add ([email protected])



HTH,
Bernie
MS Excel MVP

 

[Bernie Deitrick]

Sorry. With the address in quotes, since it needs to be a string...

.Recipients.Add ("(e-mail address removed)")


HTH,
Bernie
MS Excel MVP

 

[Pasty]

Hi there,

Its because the due date on some of the cells is less than the the date so
it is seeing it as an error. So I need to figure out how to get it to say if
the due date has passed then ignore and go through the rest and this is where
I am struggling.

Regards

Matt

 

[Bernie Deitrick]

Pasty,

You can create as many conditions as you like:

If myCell.Value <> "" And _
myCell.Value <= Now + 30 And _
myCell.Value >= Now And _
myCell(1, 2).Value <> "Notified" Then

HTH,
Bernie
MS Excel MVP