Vielen herzlichen Dank,
das mit dem Berechnen des Datums (aktuell + 4 Arbeitstage) habe ich jetzt über eine Hilfszelle geregelt. Trotzdem vielen Dank dafür.
Der Code schaut jetzt wie folgt aus:
Code:
Option Explicit
'von Ranses
'https://www.online-excel.de/excel/singsel_vba.php?f=86
Sub Excel_Workbook_via_Outlook_Senden()
Dim wksBlatt As Worksheet
Dim MyMessage As Object, MyOutApp As Object
Dim Qe As Integer
Dim AWS As String
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
'Testen ob die aktuelle Mappe schon gespeichert wurde
If ThisWorkbook.Saved = False Then
'Die letzten Änderungen wurden noch nicht gespeichert
Qe = MsgBox("Diese Mappe wurde noch nicht gespeichert, und kann nicht versandt werden!" _
& Chr$(13) & "Soll die Datei gespeichert werden?", vbInformation + vbYesNo, "Sendefehler")
If Qe = vbNo Then
'Abbruch durch Benutzer
MsgBox "Sendevorgang abgebrochen"
Exit Sub
Else
'Prüfen ob die Datei schon mal gespeichert wurde
If Right(ThisWorkbook.Name, 3) <> "xls" Then
'Nein > Speicherdialog aufrufen
Application.Dialogs(xlDialogSaveAs).Show
Else
'Speichern
ThisWorkbook.Save
End If
End If
End If
For I = 3 To WS_Count
'Aktive Arbeitsmappe wird als mail gesendet
'Übergabe des Mappennames an die Variable
AWS = ThisWorkbook.FullName
'Outlook Object erstellen
Set MyOutApp = CreateObject("Outlook.Application")
'Outlook Nachricht erstellen
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
'Empfänger
.To = ActiveSheet.Range("J1").Value
'Betreff
.Subject = "Mehrstundenliste der " & Worksheets("Gesamt").Range("K1").Value 'Date & Time
.Attachments.Add AWS
'Hier wird ein normaler Text erstellt
.Body = "Liebe Kolleginnen und Kollegen" & vbCrLf & vbCrLf & _
"anbei erhaltet ihr die Liste " & Worksheets("Gesamt").Range("K1").Value & _
" mit der Bitte um Prüfung, Korrektur und Rückgabe bis spätestens " & Worksheets("Gesamt").Range("L1").Value & "." & vbCrLf & vbCrLf & _
"LG." & vbCrLf & vbCrLf & _
"Peggy Schaupp" & vbCrLf & _
"Personalsachbearbeiterin" & vbCrLf & _
"Tel.: 627"
'Hier wird eine HTML Mail erstellt
'Dies kann zu Problemen führen, wenn der Empfänger
'nur TEXT Dateien empfangen darf.
'.HTMLBody = "Das ist ein Test." & vbCrLf & "Bitte ignorieren."
'Hier wird die Mail nochmals angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt und gesendet
.Send
End With
'Outlook schliessen
'MyOutApp.Quit
'Variablen leeren
Set MyOutApp = Nothing
Set MyMessage = Nothing
Next I
End Sub
Leider wird die Mail immer an ein und die selbe Mailadresse gesendet. Denke das liegt an folgender Stelle:
.To = ActiveSheet.Range("J1").Value
Wie kann ich es abändern, dass der Code immer die Mailadresse aus Zelle J1 von dem Blatt nimmt, wo er gerade durchläuft (Next i)?
Ich denke VBA müsste dann immer in einem Zwischenschritt das aktuelle Blatt als Active.sheet auswählen. Aber wie?
Zudem wird ja durch diesen Code immer die komplette Liste verschickt und nicht wie eigentlich gewünscht nur das eine Blatt an die eine Adresse, dann das nächste Blatt
an die nächste Mail-Adresse.
Hat vielleicht noch jemand eine Idee?
LG.
Peggy