need help fixing my code for sending automatic emails through vba - excel

Question

I have recently written a code that allows me to send an email to a specific person in a range when clicking the command button. My code originally was working fine, however, I wanted to reference my range of these peoples emails on another sheet named "Parameter" instead of the active sheet.
When I changed my code it worked but instead of sending one email it sent three. I need help ending my code so that it will only send one email.
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
Please let me know if anyone can help me with this.

Answer 1

I think you need to just change this
For Each sh In ThisWorkbook.Worksheets
If sh2.Range("K8").Value Like "?*#?*.?*" Then
to this
For Each sh In ThisWorkbook.Worksheets
If sh.Range("K8").Value Like "?*#?*.?*" Then
Because you are looping over every sheet but checking condition for sheet Parameter everytime which results TRUE for every worksheet.