Hi Peter,
Try this
Private Sub Workbook_Open()
Dim rngbody As Range
Dim c As Variant
Dim ddiff As Long
Dim mdiff As Long
Dim body As String
Dim w As Worksheet
Dim j As Integer
Dim cell As Range
Dim strto As String
For Each w In Worksheets
If w.CodeName <> "Sheet2" Then
strto = ""
For Each cell In w.Range("A3:k200")
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 6).Value) = "yes" Then
strto = strto & cell.Value & ";"
End If
Next cell
If Len(strto) > 0 Then strto = Left(strto, Len(strto) - 1)
Application.EnableEvents = False
'///New Code
Set rngbody = w.Range("A2").Resize(1, 7)
'///
' Set the initial email body. We will use this to check if we have issues later.
body = "The Following items are Due or Overdue Inspection" & ": " & Chr(9) & Chr(9) & Chr(9) & vbCrLf & vbCrLf & vbCrLf
For Each c In w.Range("F4:F" & w.Cells(Rows.Count, 6).End(xlUp).Row)
' If each value in the range is a date, then do a check for months and days.
If IsDate(c.Value) Then
ddiff = DateDiff("d", Now(), c.Value)
mdiff = DateDiff("m", Now(), c.Value)
' If greater than 1 month away, only populate the cell, do not add to the email
' body. You many want to change this.
If ddiff > 0 Then
c.Offset(0, 1).Value = ddiff & " Days from now"
Else
' Else, if we have less than one month, use days as the indicator, and
' increment the email body.
If ddiff > 1 Then
c.Offset(0, 1).Value = ddiff & " days from now"
body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -3) & Chr(9) & Chr(9) & Chr(9) & ddiff & " Days from now" & vbCrLf
Else
If ddiff = 0 Then
c.Offset(0, 1).Value = "due today"
body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -5) & ": " & Chr(9) & Chr(9) & c.Offset(0, -3) & ": " & Chr(9) & c.Offset(0, -1) & ": " & Chr(9) & " Due today" & ": " & vbCrLf
Else
c.Offset(0, 1).Value = ddiff * -1 & " days overdue"
body = body & c.Offset(0, -4) & ": " & Chr(9) & c.Offset(0, -5) & ": " & Chr(9) & c.Offset(0, -3) & ": " & Chr(9) & c.Offset(0, -1) & ": " & Chr(9) & ddiff * -1 & " Days overdue" & ": " & vbCrLf
'///New Code
Set rngbody = Union(rngbody, c.Offset(0, -5).Resize(1, 7))
'///
End If
End If
End If
End If
Next c
'///New Code
If rngbody.Rows.Count > 1 Or rngbody.Areas.Count > 1 Then
rngbody.Copy Sheet2.Range("A1")
'///
sn = Sheet2.Range("A1").CurrentRegion
c01 = "<table border=1 bgcolor=#A9BCF5 >"
On Error Resume Next
For j = 1 To UBound(sn)
c01 = c01 & "<tr><td>" & Join(Application.Index(sn, j), "</td><td>") & "</td></tr>"
Next
c01 = c01 & "</table><P></P><P></P>"
On Error GoTo 0 '//Resets the error handler to break code in the event of an error
With CreateObject("Outlook.Application").CreateItem(0)
.To = strto
.cc = ""
.bcc = "northsidevan@gmail.com"
.Subject = "Northside Leeds " & w.Name & " Safety Checks "
.HTMLBody = "The Items In The Table Below Are Overdue Please Complete and Update Spread Sheet" & c01
.display
End With
Sheet2.Cells(1).CurrentRegion.Offset(1).ClearConte nts
End If
End If
Next w
Application.EnableEvents = True
End Sub