问题
Hi i have a training workbook whereby a lot training records in the file and with the help from others helped me put the codes together and i have merged both code and played around and i am stuck now whereby it will copy all blanks rows and previous expiry date too. but
i want only to be copied and pasted on email if due date has been met
and it was not sent in past and for those only new dates. i have uploaded an sample book. please help me finish of the code. i want training due dates to be sent to different department e.g. columns V9-W35 to ABC@mail.com, columns X9-Z35 to DEF@mail.com and AE9-AG35 to HIJ@mail.com if this can be possible.
Option Explicit
Private Sub workbookopen()
Dim ws As Worksheet, ws1 As Worksheet, ws2 As Worksheet
Dim Temp(), i As Long, cell As Range, Rng As Range
Set ws = Worksheets("TrainingMatrix")
Set Rng = Sheets("TrainingMatrix").Range("AE9:AG35"): ReDim Preserve Temp(1 To Rng.Cells.Count, 1 To 3)
Set ws1 = Worksheets("EmailReport")
Set ws2 = Worksheets("EmailSent")
ws1.Range("A2:C20").EntireRow.Delete
For Each cell In Rng.Cells
If cell <> "" And IsDate(cell) And cell >= Date And cell <= Date + 60 Then
i = i + 1: Temp(i, 1) = Cells(cell.Row, 2): Temp(i, 2) = Cells(6, cell.Column): Temp(i, 3) = cell
End If
Next cell
With Sheets("EmailReport"): .Range("A2").Resize(i, 3) = Temp: .Columns.AutoFit: End With
With Sheets("EmailSent"): .Range("A2").Resize(i, 3) = Temp: .Columns.AutoFit: End With
Call SendEmails
ws1.Range("A2:C20").EntireRow.Delete
End Sub
and this is in my macro
Option Explicit
Sub SendEmails()
Dim trackerSheet As Worksheet
Set trackerSheet = ThisWorkbook.Worksheets("CTCTracker")
Dim lastRow As Long
lastRow = trackerSheet.Cells(trackerSheet.Rows.Count, "A").End(xlUp).Row
Dim trackerRange As Range
Set trackerRange = trackerSheet.Range("A5:A" & lastRow)
' Declare boolean to check if there are any expiring names
Dim anyExpiring As Boolean
Dim nameCell As Range
For Each nameCell In trackerRange
' Check: 1) There is a expiring date
' 2) Email not sent yet
' 3) Expiring date less than today + 60 días
If nameCell.Offset(0, 2).Value <> "" And _
nameCell.Offset(0, 3).Value = "" And _
nameCell.Offset(0, 2).Value <= Date + 60 Then
' Store names and expiring dates into array
Dim infoArray() As Variant
Dim counter As Long
ReDim Preserve infoArray(counter)
infoArray(counter) = Array(nameCell.Value, nameCell.Offset(0, 4).Value)
counter = counter + 1
' Stamp action log
nameCell.Offset(0, 3).Value = "Sent"
nameCell.Offset(0, 4).Value = Environ$("username")
nameCell.Offset(0, 5).Value = "E-mail sent on: " & Now()
' To be able to check later
anyExpiring = True
End If
Next nameCell
' Exit if there are not expiring contacts
If Not anyExpiring Then
MsgBox "There are no new expiring dates"
Exit Sub
End If
' Prepare message
CopyRows
' Display message to user
Dim staffMessage As String
staffMessage = ("Email has been sent for below staff")
MsgBox staffMessage
End Sub
Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("EmailSent")
ws1.Range("A1:C40").Copy
Mail_Selection_Range_Outlook_Body
End Sub
Sub Mail_Selection_Range_Outlook_Body()
Dim Rng As Range
Dim outApp As Object
Dim outMail As Object
Dim lEndRow
Dim Value As String
Set Rng = Nothing
' Only send the visible cells in the selection.
Set Rng = Sheets("EmailSent").Range("A1:C40")
If Rng Is Nothing Then
MsgBox "An unknown error has occurred. "
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(0)
With outMail
.To = "Your email address here in quotes"
.CC = ""
.BCC = ""
.Subject = "Training / Certification Expiration Report"
.HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
RangetoHTML(Rng) & "<br><br>" & _
"Text below Excel cells.</p>"
'.Attachments.Add (Application.ActiveWorkbook.FullName)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set outMail = Nothing
Set outApp = Nothing
End Sub
Function RangetoHTML(Rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
Rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
回答1:
Hi just to update on this post that this has not been resolved and can be found on https://www.mrexcel.com/board/threads/excel-to-send-email-when-all-dates-in-column-are-due.1157283/post-5618433 if anyone evercome across with this question again.
来源：https://stackoverflow.com/questions/65674212/send-email-with-all-valued-copied-from-sheet-and-pasted-on-email-body