Отправьте электронное письмо, используя VBA, когда комбинация ячеек ячейки верна - PullRequest
Новая
       27

Отправьте электронное письмо, используя VBA, когда комбинация ячеек ячейки верна

0 голосов
/ 25 октября 2019

Мой лист 'Volglijst' содержит список всех пакетов, которые были зарегистрированы для отправки. Когда посылка забирается поставщиком или курьером, служба приема товаров регистрирует дату и получателя посылки.

Когда они закрывают файл, появляется всплывающее окно с вопросом, хотят ли ониотправить подтверждение по электронной почте человеку, который запросил отправку. Когда они выбирают «да», VBA должен проверить все строки на листе «Volglijst», где есть дата в столбце B и столбце Q, а столбец S пуст (три условия должны применяться одновременно, если нет, то нет электронной почты). нужно отправить).

Я получаю свой прогноз на запуск и создание нового электронного письма, но оно остается пустым. Тело работает для другого электронного письма, только ссылка на содержимое ячейки корректируется в соответствии со строками, для которых применяются условия. 

Dim OutApp As Object
Dim OutMail As Object
Dim i As Long
Dim t As Range
Dim WkSht As Worksheet
Dim strbody As String
Set WkSht = Sheets("Volglijst")

For i = 1 To 999
If WkSht.Cells(i, 2).Value <> "" And WkSht.Cells(i, 17).Value <> "" And WkSht.Cells(i, 19).Value = "" Then
Dim rng As Range
With Application.Intersect(WkSht.Rows(i), WkSht.UsedRange)
    Set rng = WkSht.Range(WkSht.Cells(i, 3), .Cells(.Cells.Count))
         End With

If rng Is Nothing Then
Exit Sub
End If
End If
Next
On Error Resume Next

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "<font size=""3"" face=""Calibri"">" & _
"Beste Collega,<br><br>" & _
"Uw pakket met nummer <B>" & WkSht.Cells(WkSht.Rows(i), 1).Value & "</B> werd <B>" & WkSht.Cells(WkSht.Rows(i), 17).Value & "</B> opgehaald door <B>" & WkSht.Cells(WkSht.Rows(i), 16).Value & "</B>.<br>" & _
"Bijkomende opmerkingen goederenontvangst: <B>" & WS.Cells(WkSht.Rows(i), 18).Value & "</B>.<br>" & _
"<br><br>In geval van vragen gelieve contact op te nemen." & _
"<br><br> Met vriendelijke groeten, </font>"
On Error Resume Next


With OutMail
.To = WS.Cells(WkSht.Rows(i), 5).Value
.CC = ""
.BCC = ""
.Subject = "Ophaling pakket " & WS.Cells(i, 1).Value & ""
.HTMLBody = strbody
.Display  'or use .Send
End With

Для каждой строки со столбцом B может быть отправлено отдельное электронное письмо. <> "";столбец Q <> "", столбец S = "", а получателем является адрес электронной почты столбца E в этой строке. Подробности в теле письма также должны быть в соответствующей строке.

Ответы [ 2 ]

0 голосов
/ 25 октября 2019

Попытка разделить это, но у вас есть пара существенных проблем:

  • Вы используете i в аспекте outlook этого письма ВНЕ цикла, так что выпросто используя i = 999, или это должно было быть в цикле?

  • Ссылки в ваших strbody были на разные листы ... проверьте ваши ссылки. Я вызвал первое вхождение в подпрограмме Excel_Activities, когда начал определять каждое использование. 

Public bdy_a as string, bdy_b as string, bdy_c as string, bdy_d as string
Public to_ as string
Public sub_ as string
'
Sub Excel_Activities()
    Dim i as Long, t As Range
    Dim WkSht As Worksheet
    Dim strbody As String
    Set WkSht = Sheets("Volglijst")
    For i = 1 To 999
        If WkSht.Cells(i, 2).Value <> "" And WkSht.Cells(i, 17).Value <> "" And WkSht.Cells(i, 19).Value = "" Then
            Dim rng As Range
            With Application.Intersect(WkSht.Rows(i), WkSht.UsedRange)
                Set rng = WkSht.Range(WkSht.Cells(i, 3), .Cells(.Cells.Count))
            End With
            If rng Is Nothing Then
                Exit Sub
            Else
                bdy_a = WkSht.Cells(i, 1).Value
                bdy_b = WkSht.Cells(i, 17).Value
                bdy_c = WkSht.Cells(i, 16).Value
                bdy_d = WS.Cells(i, 18).Value 'IS THIS CORRECT SHEET?
                to_ = WS.Cells(WkSht.Rows(i), 5).Value
                sub_ = WS.Cells(i, 1).Value
                Application.Run("Outlook_Activities")
            End If
        End If
    Next
End Sub

Затем обработать сохраненные значения, чтобы создать нужную электронную почту, котораяПохоже, что происходит в Loop на основе использования i в исходном сообщении strbody. 

Private Sub Outlook_Activities()
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "<font size=""3"" face=""Calibri"">" & "Beste Collega,<br><br>" & "Uw pakket met nummer <B>" & bdy_a & "</B> werd <B>" & bdy_b & "</B> opgehaald door <B>" & bdy_c & "</B>.<br>" & "Bijkomende opmerkingen goederenontvangst: <B>" &  & "</B>.<br>" & "<br><br>In geval van vragen gelieve contact op te nemen." & "<br><br> Met vriendelijke groeten, </font>"

    With OutMail
        .To = to_
        .CC = ""
        .BCC = ""
        .Subject = "Ophaling pakket " & sub_ & ""
        .HTMLBody = strbody
        .Display  'or use .Send
    End With
End Sub
0 голосов
/ 25 октября 2019

Я полагаю, что вам нужно следующее: этот цикл будет проходить от строки 1 до последней строки UsedRange, проверять, не являются ли столбцы B & Q пустыми, а столбец S пустым, а затем обрабатывать электронную почту для каждой строки: 

Sub LoopThroughRange_SendEmail()
Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object: Set OutMail = OutApp.CreateItem(0)
Dim i As Long
Dim strbody As String
Dim WkSht As Worksheet: Set WkSht = Sheets("Volglijst")

For i = 1 To WkSht.UsedRange.Rows.Count
    If WkSht.Cells(i, "B").Value <> "" And WkSht.Cells(i, "Q").Value <> "" And WkSht.Cells(i, "S").Value = "" Then
        strbody = "<html><body><font size=""3"" face=""Calibri"">Beste Collega,<br><br>Uw pakket met nummer <b>" & _
        WkSht.Cells(i, "A").Value & "</b> werd <b>" & WkSht.Cells(i, "Q").Value & "</b> opgehaald door <b>" & _
        WkSht.Cells(i, "P").Value & "</b>.<br>Bijkomende opmerkingen goederenontvangst: <b>" & _
        WkSht.Cells(i, "R").Value & "</B>.<br><br><br>In geval van vragen gelieve contact op te nemen.<br><br>" & _
        "Met vriendelijke groeten, </font></body></html>"

    With OutMail
        .To = WkSht.Cells(i, "E").Value
        .CC = ""
        .BCC = ""
        .Subject = "Ophaling pakket " & WkSht.Cells(i, "A").Value & ""
        .HTMLBody = strbody
        .Display  'or use .Send
    End With

    End If
Next i
End Sub

ОБНОВЛЕНИЕ:

Чтобы проверить адрес электронной почты, прежде чем пытаться отправить электронное письмо, поможет следующее, оно позволит использовать несколько адресов электронной почты в одной ячейке. разделены; 

Sub LoopThroughRange_SendEmail()
Dim oRegEx As Object
Set oRegEx = CreateObject("VBScript.RegExp")
Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object: Set OutMail = OutApp.CreateItem(0)
Dim i As Long
Dim strbody As String
Dim WkSht As Worksheet: Set WkSht = Sheets("Volglijst")

For i = 1 To WkSht.UsedRange.Rows.Count
    If ValidEmail(WkSht.Cells(i, "E").Value, oRegEx) Then
        If WkSht.Cells(i, "B").Value <> "" And WkSht.Cells(i, "Q").Value <> "" And WkSht.Cells(i, "S").Value = "" Then
            strbody = "<html><body><font size=""3"" face=""Calibri"">Beste Collega,<br><br>Uw pakket met nummer <b>" & _
            WkSht.Cells(i, "A").Value & "</b> werd <b>" & WkSht.Cells(i, "Q").Value & "</b> opgehaald door <b>" & _
            WkSht.Cells(i, "P").Value & "</b>.<br>Bijkomende opmerkingen goederenontvangst: <b>" & _
            WkSht.Cells(i, "R").Value & "</B>.<br><br><br>In geval van vragen gelieve contact op te nemen.<br><br>" & _
            "Met vriendelijke groeten, </font></body></html>"

            With OutMail
                .To = WkSht.Cells(i, "E").Value
                .CC = ""
                .BCC = ""
                .Subject = "Ophaling pakket " & WkSht.Cells(i, "A").Value & ""
                .HTMLBody = strbody
                .Display  'or use .Send
            End With
        End If
    Else
        'email address is not valid
    End If
Next i
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
...