需要帮助修复通过vba发送自动电子邮件的代码
我最近写了一个代码，允许我发送一封电子邮件给一个特定的人在一个范围内点击命令button。 我的代码最初工作正常，但是，我想引用另一个名为“参数”表上的这些人的电子邮件的范围，而不是活动工作表。
当我改变了我的代码，但它的工作，而不是发送一封电子邮件发送三。 我需要帮助结束我的代码，以便它只会发送一封电子邮件。
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 请让我知道是否有人可以帮助我。
我想你只需要改变这一点
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。