[英]need help fixing my code for sending automatic emails through vba
我最近編寫了一個代碼,允許我在單擊命令按鈕時向一個范圍內的特定人員發送電子郵件。 我的代碼最初工作正常,但是,我想在另一張名為“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
如果有人能幫助我,請告訴我。
我想你需要改變它
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。
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.