Как отправить электронное письмо с Excel, когда дата в столбце равна или меньше, чем сегодняшняя дата?

Question

У меня есть 3 столбца: A) Предприятия B) Адрес электронной почты, соответствующий предприятию C) Да или Нет

Если в столбце C есть ДА, я хочу автоматически отправить сообщение на электронную почтув колонке B

Спасибо за советы.

Это то, что я получил сейчас, но оно не работает, ничего не происходит:

Sub Test2()

    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim cell As Range

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "C").Value) = "yes" _
           And LCase(Cells(cell.Row, "D").Value) <> "send" Then

            Set OutMail = OutApp.CreateItem(olMailItem)

            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Reminder"
                .Body = "Dear " & Cells(cell.Row, "A").Value _
                      & vbNewLine & vbNewLine & _
                        "Please contact us to discuss bringing " & _
                        "your account up to date."
                        Attachments.Add ("\\C:\test.pdf")
                               .Send  '
            End With
            On Error GoTo 0
            Cells(cell.Row, "D").Value = "send"
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Answer 1

Приведенный ниже код будет перебирать строку 2 до последней строки в UsedRange и проверять, что столбцы A, B и C не пусты, а также проверять, чтобы убедиться, что столбец D пуст, что код использует в качестве флага. чтобы показать, было ли письмо отправлено ранее.

Я добавил функцию проверки Regex в код для проверки адреса электронной почты.

Sub LoopThroughRange_SendEmail()
Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object: Set OutMail = OutApp.CreateItem(0)
Dim oRegEx As Object
Set oRegEx = CreateObject("VBScript.RegExp")
Dim i As Long
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet you are working with

For i = 2 To ws.UsedRange.Rows.Count
'loop from Row 2 To Last Row in UsedRange
    If ws.Cells(i, "A").Value <> "" And ws.Cells(i, "B").Value <> "" And ws.Cells(i, "C").Value = "Yes" And ws.Cells(i, "D").Value = "" Then
    ' make sure that Columns A, B & C are not empty and D is empty (which we will use as a flag to show that the email did get sent.
        If ValidEmail(ws.Cells(i, "B").Value, oRegEx) Then
            With OutMail
                .To = ws.Cells(i, "B").Value
                .CC = ""
                .BCC = ""
                .Subject = "Reminder"
                .Body = "Dear " & Cells(cell.Row, "A").Value _
                          & vbNewLine & vbNewLine & _
                            "Please contact us to discuss bringing " & _
                            "your account up to date."
                .Attachments.Add ("\\C:\test.pdf")
                .Display '.Send
            End With
            ws.Cells(i, "D").Value = "Sent @ " & Format(Now(), "yyyy-MM-dd hh:mm:ss")
        Else
            ws.Cells(i, "D").Value = "Email not valid"
        End If
    End If
End Sub

Public Function ValidEmail(pAddress As String, ByRef oRegEx As Object) As Boolean
    With oRegEx
        .Pattern = "^(([a-zA-Z0-9_\-\.\']+)@((\[[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.)|(([a-zA-Z0-9\-]+\.)+))([a-zA-Z]{2,4}|[0-9]{1,3})(\]?)(\s*;\s*|\s*$))+$" 'pattern for multiple email addresses included
        ValidEmail = .test(pAddress)
    End With
End Function