как исправить код VBA, который отправляет дубликаты электронных писем вместо прикрепления всего файла Excel - PullRequest
Новая
       9

как исправить код VBA, который отправляет дубликаты электронных писем вместо прикрепления всего файла Excel

0 голосов
/ 17 мая 2019

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

Sub Rectangle7_Click()

Const cFirst As Integer = 20
Const cLast As Integer = 65
Const cRequest As String = "New Request"

Dim i As Integer
For i = cFirst To cLast


If Range("E" & i).Value = "" Then
MsgBox "Provide the PC name from KE53"
Exit Sub


ElseIf Range("G" & i).Value = "" Then
MsgBox "Please provide the user responsible (Sector) maintained in KE53 
for this PC"
Exit Sub

ElseIf Range("K" & i).Value = "" Then
MsgBox "Provide the company code where the PC needs to be extended"

Exit Sub
End If

ActiveSheet.Unprotect Password:="PROFITCENTER"
Selection.AutoFilter
ActiveSheet.Range("$B$19:$L$65").AutoFilter Field:=1, Criteria1:="=AD*", 
_
Operator:=xlAnd


ActiveWorkbook.SaveAs Filename:="C:\Apps\" & "Request" & Format(Now(), 
"DD-MM-YYYY"), _


Dim OutApp As Object
Dim OutMail As Object

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

On Error Resume Next

With OutMail
    .To = 
    .CC = ""
    .BCC = ""
    .Subject = " Request_" & "" & Format(Now(), "DD-MM-YYYY")
    .HTMLBODY = "Thank You"
    .Attachments.Add ActiveWorkbook.FullName
    .Display

End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

Next
End Sub

пожалуйста, помогите мне, что пошло не так, почему он отправляет несколько электронных писем, а не просто прикрепляет весь лист?

1 Ответ

0 голосов
/ 17 мая 2019

Это должно работать. 

Sub Rectangle7_Click()

    Const cFirst As Integer = 20
    Const cLast As Integer = 65
    Const cRequest As String = "New Request"

    Dim i As Integer
    For i = cFirst To cLast
        If Range("E" & i).Value = "" Then
            MsgBox "Provide the PC name from KE53"
            Exit Sub

        ElseIf Range("G" & i).Value = "" Then
            MsgBox "Please provide the user responsible (Sector) maintained in KE53 for this PC"
            Exit Sub

        ElseIf Range("K" & i).Value = "" Then
            MsgBox "Provide the company code where the PC needs to be extended"
            Exit Sub
        End If
    Next i

    ActiveSheet.Unprotect Password:="PROFITCENTER"
    Selection.AutoFilter
    ActiveSheet.Range("$B$19:$L$65").AutoFilter Field:=1, Criteria1:="=AD*", Operator:=xlAnd

    ActiveWorkbook.SaveAs Filename:="C:\Apps\" & "Request" & Format(Now(), "DD-MM-YYYY")

    Dim OutApp As Object
    Dim OutMail As Object

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

    On Error Resume Next

    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = " Request_" & "" & Format(Now(), "DD-MM-YYYY")
        .HTMLBODY = "Thank You"
        .Attachments.Add ActiveWorkbook.FullName
        .Display

    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub
...