Thanks for the assist, not sure if this is the best way but I combined both macros into one and all appears to be working so far.
Still got some way to go, but so far it is doing what I want.
Thanks again I appreciate the help. I am sure there will be another stumbling block just around the corner. I would appreciate your feedback on the code I have so far.
Mick
Sub Macro1()
Dim rngCell As Range
Dim rngMyDataSet As Range
Dim Rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim EmailSendTo As String
Dim MailBody As String
Dim EmailRecipient As String
Dim Signature As String
Application.ScreenUpdating = False
With ActiveSheet
If .FilterMode Then .ShowAllData
Set Rng = .Range("A7", .Cells(.Rows.Count, 1).End(xlUp))
End With
For Each rngCell In Rng
If rngCell.Offset(0, 6) > 0 Then
ElseIf rngCell.Offset(0, 5) > Evaluate("Today() +7") And _
rngCell.Offset(0, 5).Value <= Evaluate("Today() +30") Then
rngCell.Offset(0, 6).Value = Date
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Dear " & rngCell.Offset(0, 1).Value & vbNewLine & "According to our records your " & Range("F6").Value & " is due for renewal on " & rngCell.Offset(0, 5).Value & vbNewLine & _
"Could you please ensure you send us a copy of your renewal prior to this date."
EmailSendTo = rngCell.Offset(0, 0).Value
EmailSubject = Sheets("sheet1").Range("F6").Value
EmailRecipient = rngCell.Offset(0, 1).Value
Signature = "C:\Documents and Settings\" & Environ("rmm") & _
"\Application Data\Microsoft\Signatures\rm.htm"
On Error Resume Next
With OutMail
.To = EmailSendTo
.CC = "
admin@.com.au"
.BCC = ""
.Subject = EmailSubject
.Body = strbody
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next rngCell
Application.ScreenUpdating = True
End Sub
