macro looping and email results

[Guacamoley]

I have been trying to put together a database that shows manditory training course expiry dates for different people and get an email to be automatically sent to them when the are nearly out of compliance.

Below is what I have come to so far. It starts by going through collum 'D' until blank and list the dates that are 14 days from today in an email to the user listed in collum 'B'. What I would ulitmatly like is for it to be able to loop some how so that it can also check from collum 'D' through to 'X' and list all of the dates that are nearly 14 days out of todays date to be listed all in one email to the user as specified for that row.

Im am sorry if i have not explained this very well, I am still learning!
I hope someone can help me.


Sub EmailRenewalDue()
'Set variables
Dim Maildb As Object
Dim MailDoc As Object
Dim Body As Object
Dim Session As Object
Dim cell As Range
Dim UID As String
Dim DaysLeft As Long
Application.ScreenUpdating = False
Application.UserControl = False

'initiate lotus session
Set Session = CreateObject("Lotus.NotesSession")

On Error GoTo Cleanup

UID = Application.InputBox _
(Prompt:="Please enter your UserID e.g U123456", _
Title:="UserID")

Call Session.Initialize
Set Maildb = Session.GETDATABASE("", "C:\Documents and Settings\" & UID & "\Local Settings\Application Data\Lotus\Notes\Data\bookmark.nsf")

If Not Maildb.IsOpen = True Then
Call Maildb.Open
End If

For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)

If Cells(cell.Row, "D").Value >= Date And Cells(cell.Row, "D").Value <= Date + 7 Then

Set MailDoc = Maildb.CREATEDOCUMENT
On Error Resume Next

With MailDoc

Call MailDoc.replaceitemvalue("Form", "Memo")
Call MailDoc.replaceitemvalue("SendTo", cell.Value)
Call MailDoc.replaceitemvalue("Subject", "Test")

DaysLeft = Cells(cell.Row, "G").Value - Date

Set Body = MailDoc.CREATERICHTEXTITEM("Body")

Call Body.APPENDTEXT("Test " & Cells(cell.Row, "D").Value)

MailDoc.SAVEMESSAGEONSEND = True
Call MailDoc.replaceitemvalue("PostedDate", Now())
Call MailDoc.Send(False)

' If Cells(cell.Row, "M").Value = "" Then
' Cells(cell.Row, "M").Value = "Email sent on: " & Date
' End If

End With
On Error GoTo 0
Set MailDoc = Nothing
End If
Next cell
Cleanup:
Set Session = Nothing
Application.UserControl = True
Application.ScreenUpdating = True
Set Maildb = Nothing
Set MailDoc = Nothing
Set Body = Nothing
Set Session = Nothing

End Sub