需要帮助修复我的代码，通过vba发送自动电子邮件

Question

我最近编写了一个代码，允许我在单击命令按钮时向一个范围内的特定人员发送电子邮件。 我的代码最初工作正常，但是，我想在另一张名为“Parameter”的工作表而不是活动工作表上引用我的这些人的电子邮件范围。

当我更改我的代码时，它工作但不是发送一封电子邮件，而是发送了三封。 我需要帮助来结束我的代码，以便它只发送一封电子邮件。

Private Sub JLechner_Click()
Dim sh As Worksheet
Dim sh2 As Worksheet
    Dim wb As Workbook
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String



    TempFilePath = Environ$("temp") & "\"

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2016
        FileExtStr = ".xlsm": FileFormatNum = 52
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
     Set sh2 = ThisWorkbook.Sheets("Parameter")

    For Each sh In ThisWorkbook.Worksheets
        If sh2.Range("K8").Value Like "?*@?*.?*" Then

            sh.Copy
            Set wb = ActiveWorkbook

            TempFileName = "Sheet " & sh.Name & " of " _
                         & ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

            Set OutMail = OutApp.CreateItem(0)

            With wb
                .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

                strbody = "(See below for english version)" & vbNewLine & vbNewLine & _
              "Hallo," & vbNewLine & vbNewLine & _
              "Maß " & sh.Range("E4").Value & " muss geprüft werden." & vbNewLine & _
              "Bitte im Sharepoint die prüfung durchführen." & vbNewLine & vbNewLine & _
              "Die Maßnahmenblätter finden Sie unter folgendem Link:" & vbNewLine & vbNewLine & _

              "Wenn die Prüfung abgeschlossen ist, bitte die Taste auf der rechten Seite der tabelle drücken, um die Maßnahme zum folgendem Bearbeiter weiterzuleiten." & vbNewLine & _
              "Wenn Sie Unterstützung brauchen, bitte kontaktieren Sie Bob and Ryan." & vbNewLine & vbNewLine & _
              "Vielen Dank." & vbNewLine & _
              "Mit freundlichen Grüßen" & vbNewLine & _
              "Team" & vbNewLine & vbNewLine & vbNewLine & _
              "----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------" & vbNewLine & vbNewLine & vbNewLine & _
              "Hello," & vbNewLine & vbNewLine & _
              "Measure " & sh.Range("E4").Value & " must be checked." & vbNewLine & _
              "Please access the Sharepoint and proceed with your corresponding check." & vbNewLine & vbNewLine & _
              "Measures can be found using the following link:" & vbNewLine & vbNewLine & _

              "When finished, please forward the measure to the next responsible person using the buttons on the right side of the table." & vbNewLine & _
              "If you require support, contact any MTM responsible persons." & vbNewLine & vbNewLine & _
              "Thank you," & vbNewLine & _
              "Best regards," & vbNewLine & _
              "Team"


                On Error Resume Next
                With OutMail
                    .To = sh2.Range("K8").Value
                    .CC = ""
                    .BCC = ""
                    .Subject = "Bitte Maßnahmenblatt bearbeiten: " & sh.Range("E4").Value
                    .Body = strbody


                    .Send   'or use .Display
                End With
                On Error GoTo 0

                .Close savechanges:=False
            End With

            Set OutMail = Nothing

            Kill TempFilePath & TempFileName & FileExtStr

        End If
    Next sh

    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

如果有人能帮助我，请告诉我。

Answer 1

我想你需要改变它

For Each sh In ThisWorkbook.Worksheets
    If sh2.Range("K8").Value Like "?*@?*.?*" Then

对此

For Each sh In ThisWorkbook.Worksheets
    If sh.Range("K8").Value Like "?*@?*.?*" Then

因为您循环遍历每个工作表但每次都检查工作表参数的条件，每个工作表的结果为TRUE。