excel - Send all Due to date and names in one email

Question

Hello Everyone i was wondering if anyone can help me resolve my problem., i have got code which i found from the net which is working absolutely perfect however only problem is that when there is more than one due date in the column it will send email each time instead of sending all due date and names in One email at same time. Names it is on column A, Expiry Date it is in column E, and email stamp as sent in Column F, below its the code.

Private Sub Workbook_Open()
  Dim Email As String, Subj As String, Msg As String, wBox As String
  Dim RowNo As Long, i As Long, ky As Variant, cad As Variant
  Dim wsEmail As Worksheet, OutApp As Object, OutMail As Object, dic As Object
 
  Set wsEmail = ThisWorkbook.Sheets("Tracker")
  Set dic = CreateObject("scripting.dictionary")
 
With wsEmail
    For RowNo = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
    If .Cells(RowNo, "E") <> "" Then
      If .Cells(RowNo, "F") = "" And .Cells(RowNo, "E") <> "" And .Cells(RowNo, "E") <= Date + 60 Then
        If dic.exists(.Cells(RowNo, "F").Value) Then
          dic(.Cells(RowNo, "A").Value) = dic(.Cells(RowNo, "A").Value) & RowNo & "|"
        Else
          dic(.Cells(RowNo, "A").Value) = RowNo & "|"
        End If
      End If
      End If
    Next
    
    For Each ky In dic.keys
      cad = Left(dic(ky), Len(dic(ky)) - 1)
      cad = Split(cad, "|")
      wBox = ""
      dBox = ""
      For i = 0 To UBound(cad)
       wBox = wBox & " " & wsEmail.Cells(cad(i), "A")
       dBox = wsEmail.Cells(cad(i), "E")
        .Cells(cad(i), "F") = "Sent"
         .Cells(cad(i), "G") = Environ("username")
        .Cells(cad(i), "H") = "E-mail sent on: " & Now()
      Next
      On Error Resume Next
      
      Set OutApp = GetObject("Outlook.Application")
      On Error GoTo 0
      If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
      Do: Loop Until Not OutApp Is Nothing
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
      
        Subj = wBox & Space(1) & "from will expire soon"
        
        Msg = "Hi" & vbCrLf & vbCrLf _
          & "This is an automated e-mail to let you know that" & wBox & Space(1) & " will expire as follow;" & vbCrLf & vbCrLf _
          & "Expiry date:" & dBox & vbCrLf & vbCrLf & "Many Thanks " & vbCrLf _
          & vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
          
        .To = "Sent to"
        .CC = ""
        .BCC = ""
        .Subject = Subj
        .ReadReceiptRequested = False
        .Body = Msg
        .Display
      End With
      
              mystring = ("Email has been sent for below staff;") & _
                   vbCrLf & vbCrLf & ky
                MsgBox mystring
                
      Set OutApp = Nothing
      Set OutMail = Nothing
    Next
  End With
End Sub

is there any way to do this?

标签： excelvba

Answer 1

这应该让你开始。

阅读代码的注释并根据您的需要进行调整。

Private 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, 4).Value <> "" And _
            nameCell.Offset(0, 5).Value = "" And _
            nameCell.Offset(0, 4).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, 5).Value = "Sent"
            nameCell.Offset(0, 6).Value = Environ$("username")
            nameCell.Offset(0, 7).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 not expiring contacts"
        Exit Sub
    End If
    
    
    ' Prepare message
    Dim namesList As String
    For counter = 0 To UBound(infoArray)
        namesList = namesList & infoArray(counter)(0) & vbTab & vbTab & " | " & vbTab & vbTab & infoArray(counter)(1) & vbNewLine
    Next counter
    
    Dim emailBodyTemplate As String
    emailBodyTemplate = "This is an automated e-mail to let you know that the following CTC will expire as follow:" & vbCrLf & vbCrLf & _
                        "Name" & vbTab & vbTab & vbTab & " | " & vbTab & vbTab & vbTab & " CTC Expiry date" & vbCrLf & _
                        "<namesList>" & vbCrLf & vbCrLf & _
                        "Many Thanks " & vbCrLf & _
                        vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
    
    Dim emailBody As String
    emailBody = Replace(emailBodyTemplate, "<namesList>", namesList)
    
    ' Start outlook (late bound)
    Dim outApp As Object
    On Error Resume Next
    Set outApp = GetObject("Outlook.Applicatin")
    On Error GoTo 0
    
    ' If outlook is not running, start an instance
    If outApp Is Nothing Then Set outApp = CreateObject("Outlook.Application")
    Do: Loop Until Not outApp Is Nothing
    
    ' Compose email
    Dim outMail As Object
    Set outMail = outApp.CreateItem(0)
    With outMail
        .To = "Sent to"
        .CC = ""
        .BCC = ""
        .Subject = "CTC will expire soon"
        .ReadReceiptRequested = False
        .Body = emailBody
        .Display
    End With
      
    ' Display message to user
    Dim staffMessage As String
    staffMessage = ("Email has been sent for below staff")
    MsgBox staffMessage
        
    ' Clean up
    Set outApp = Nothing
    Set outMail = Nothing
    
End Sub

让我知道它是否有效