none
Automatically send an email using macros code RRS feed

  • Question

  • Hello

    I'm trying to write a macros code on excel that will view due dates that have been entered by individuals checking parts out and then send them an email reminding them that the part is due. I have a column also for their emails on the same excel sheet. The emails all have the same body msg except for the part number, the due date, the name, and the email its being sent to. I'm struggling to get macros to use the email in the same row that it has found the date on. This is what I have so far:

    Sub email()

        Dim r As Range
        Dim cell As Range

        Set r = Range("G2:G64")

        For Each cell In r

            If cell.Value = Date Then

                Dim Email_Subject, Email_Send_From, Email_Send_To, _
                Email_Cc, Email_Bcc, Email_Body As String
                Dim Mail_Object, Mail_Single As Variant

                Email_Subject = "Gauge Return Date"
                Email_Send_From = "***@*ob.com"
                Email_Send_To = Cells(ActiveCell.Row, 2)
                Email_Body = "Dear " & Cells(ActiveCell.Row, 1) & "," & vbCrLf & vbCrLf & "The gauge below was due by " & Cells(ActiveCell.Row, 7) & ":" & vbCrLf & vbCrLf & "Gauge Number: " & Cells(ActiveCell.Row, 5) & vbCrLf & vbCrLf & " Please be sure to return the gauge or re-check it out. If re-checking out a gauge, please close out the current check out and mark as: returned; then begin a new one." & vbCrLf & vbCrLf & "Thanks," & vbCrLf & vbCrLf & "Gauge Lab"

                On Error GoTo debugs
                Set Mail_Object = CreateObject("Outlook.Application")
                Set Mail_Single = Mail_Object.CreateItem(0)
                With Mail_Single
                .Subject = Email_Subject
                .To = Email_Send_To
                .cc = Email_Cc
                .BCC = Email_Bcc
                .Body = Email_Body
                .send
                End With

            End If

        Next


        Exit Sub

    debugs:
            If Err.Description <> "" Then MsgBox Err.Description
    End Sub

    Wednesday, May 24, 2017 12:27 PM

All replies

  • Hi AhmadShehata

    I have not had time to test your code, but I think that you problem lies in the line:

    "Email_Send_To = Cells(ActiveCell.Row, 2)"

    It is not the "ActiveCell" that you are looking at, but the "cell" in your For Next loop.

    Try replacing that line with:

    Email_Send_To = Cells(cell.Row, 2)

    Andy C

    Wednesday, May 24, 2017 3:31 PM
  • Hi AhmadShehata

    I have not had time to test your code, but I think that you problem lies in the line:

    "Email_Send_To = Cells(ActiveCell.Row, 2)"

    It is not the "ActiveCell" that you are looking at, but the "cell" in your For Next loop.

    Try replacing that line with:

    Email_Send_To = Cells(cell.Row, 2)

    Andy C

    Wednesday, May 24, 2017 3:33 PM
  • Try it like this - don't use ActiveCell since you are not selecting the cells in your range of dates

        

    Sub email()
        Dim Mail_Object As Outlook.Application
        Dim Mail_Single As Outlook.MailItem
        Dim rngDates As Range
        Dim rngDate As Range

        Set rngDates = Range("G2:G64")
        Set Mail_Object = CreateObject("Outlook.Application")

        For Each rngDate In rngDates
            If rngDate.Value = Date Then
                On Error GoTo debugs
                Set Mail_Single = Mail_Object.CreateItem(0)
                With Mail_Single
                    .Subject = "Gauge Return Date"
                    .To = Cells(rngDate.Row, 2).Value
                    .cc = "WhoeverGetsCCd@company.com"
                    .BCC = "WhoeverGetsBCCd@company.com"
                    .Body = "Dear " & Cells(rngDate.Row, 1) & "," & vbCrLf & vbCrLf & _
                        "The gauge below was due by " & rngDate.Value & ":" & vbCrLf & vbCrLf & _
                        "Gauge Number: " & Cells(rngDate.Row, 5) & vbCrLf & vbCrLf & _
                        " Please be sure to return the gauge or re-check it out. " & _
                        "If re-checking out a gauge, please close out the current " & _
                        "check out and mark as: returned; then begin a new one." & vbCrLf & vbCrLf & _
                        "Thanks," & vbCrLf & vbCrLf & "Gauge Lab"
                    .send
                End With
            End If
        Next

        Mail_Object.Quit
        
        Exit Sub

    debugs:
            If Err.Description <> "" Then MsgBox Err.Description
    End Sub

    Wednesday, May 24, 2017 3:39 PM