leider ich schon wieder.
Habe festgestellt das Outlook Mails immer doppelt versendet.
Sobald die Daten in dem Blatt Frühschicht abgesendet werden und im Blatt Action Plan eingehen im Bereich B7:B200 wird ein Makro zum Versand einer Email aufgerufen.
Wenn ich das Makro Email_an_PMV_077 manuell aufrufe versendet Outlook die Mail nur einmal
Klicke ich im Blatt Action Plan in Zelle B7 wird auch nur eine Mail versendet.
Sobald ich aber im Blatt Frühschicht das Makro Schreiben_PMV_Früh benutze. Also die Automatische Prozedur wird die Mail doppelt versendet.
Finde einfach den Fehler nicht.
Gruß Uli
Public Sub Schreiben_PMV_Früh()
Application.ScreenUpdating = False
'schreibt in geschlossene PMV
Dim sPfad As String ' der Ordner-Pfad der Excel-Mappen
Dim sDatei As String ' die zu beschreibende Datei
Dim WkSh_Q As Worksheet ' das Quell-Tabellenblatt - die Herkunft
Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - das Ergebnis
Dim ersteFreieZelle As Long
'Pfad User
'sPfad = "C:\Users\ElCapitan\Desktop\Prüflehren\"
'Pfad Uli
sPfad = ThisWorkbook.Path & "\"
sDatei = "PT05_FB_0001_Aktions- und Maßnahmenplan_MB.xlsm"
' PT05_FB_0001_Aktions- und Maßnahmenplan_MB.xlsm
'Application.ScreenUpdating = False
If Dir(sPfad & sDatei, vbNormal) "" Then
Workbooks.Open (sPfad & sDatei)
ThisWorkbook.Activate
'Application.ActiveWindow.Visible = False
Else
MsgBox "Den angegebenen Ordner """ & sPfad & """" & Chr(10) & _
"und/oder die gesuchte Datei """ & sDatei & """ gibt es nicht!", _
16, " Hinweis für " & Application.UserName
Exit Sub
End If
Set WkSh_Q = ThisWorkbook.Worksheets("Frühschicht")
'alt
'Set WkSh_Z = Workbooks(sDatei).Worksheets("Action Plan_P992_077")
'neu
Set WkSh_Z = Workbooks(sDatei).Worksheets(WkSh_Q.Range("A74").Value)
ersteFreieZelle = WorksheetFunction.Max(7 - 1, WkSh_Z.Range("B29").End(xlUp).Row) + 1
WkSh_Z.Unprotect ""
WkSh_Q.Cells.Range("C74:E74").Copy Destination:=WkSh_Z.Range("B" & ersteFreieZelle & ":D" & _
ersteFreieZelle)
'datum in action plan schreiben
WkSh_Z.Range("B" & ersteFreieZelle) = Date
WkSh_Z.Protect ""
MsgBox "Die Daten wurden erfolgreich übergeben.", _
64, " Information für " & Application.UserName
With WkSh_Z.Parent
.Save
.Saved = True
'.Close False
End With
Set WkSh_Q = Nothing: Set WkSh_Z = Nothing
End Sub
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Intersect(Target, Range("B7:B200")) Is Nothing _
Then Exit Sub
Call Email_an_PMV_078
End Sub
Sub Email_an_PMV_078()Application.ScreenUpdating = False
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = "XXXXXXXXXXXX"
.Subject = "Neuer Eintrag in Maßnahmenplan Prüflehren 078"
.Body = "Hallo. Es gibt ein neues Problem mit der Prüflehre P992_078 im Bereich Montage. Bitte öffnen Sie den Action und Maßnahmenplan im Ordner Prüflehren"
.Send 'Sendet die Email automatisch
End With
End Sub