Hallo Ihr Lieben,
ich habe eine Arbeitsmappe mit vielen Tabellenblättern. In jedem Tabellenblatt steht in der Zella J1 eine E-Mail-Adresse. (Bei jedem Blatt ist diese Mail-Adresse unterschiedlich.)
Nun möchte ich per VBA ab Tabellenblatt 3 alle Blätter einzeln an die zuständige E-Mailadresse aus J1 des jeweiligen Blattes als Excel-E-Mail-Anhang versenden.
Der E-Mail-Text soll dann in etwa so aussehen:
Liebe Kolleginnen und Kollegen,
anbei erhaltet Ihr die Liste von der "40. KW" (KW steht im 1. Tabellenblatt in Zelle K1) mit der Bitte um Prüfung, Korrektur und Rücksendung
bis spätestens _______. (Hier soll automatisch ein Datum eingetragen werden. Wenn möglich das heutige plus 4 Arbeitstage.)
Habt Ihr da eine Idee?
LG.
Peggy
Hallo Peggy,
mal als Ansatz
Code:
Option Explicit
'von Ranses
'https://www.online-excel.de/excel/singsel_vba.php?f=86
Sub Excel_Workbook_via_Outlook_Senden()
Dim MyMessage As Object, MyOutApp As Object
Dim Qe As Integer
Dim AWS As String
'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
'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 = "Testmeldung von Excel2000 " & Date & Time
.Attachments.Add AWS
'Hier wird ein normaler Text erstellt
.Body = "Liebe Kolleginnen und Kollegen" & vbCrLf & vbCrLf & _
"anbei erhaltet ihr die Liste ..... " & acivesheet.Range("K1").Value & _
"bis spätestens " & Format(Date - 4, "tt.MM.YYYY")
'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
End Sub
Hallo Stefan,
vielen Dank für Deine schnelle Antwort.
Der Ansatz ist schon mal gut. Hier wird die Arbeitsmappe komplett an eine E-Mail versendet. Ich möchte aber die Tabellenblätter an verschiedene E-Mail-Adressen versenden.
Blatt 1 - E-Mail-Adresse1 in Zelle Blatt1!J1
Blatt 2 - E-Mail-Adresse2 in Zelle Blatt2!J1
usw.
LG.
Peggy
Hallo Peggy,
ich hoffe, ich habe alles erwischt
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
'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
'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)
For Each wksBlatt In ThisWorkbook.Worksheets
With MyMessage
'Empfänger
.To = wksBlatt.Range("J1").Value
'Betreff
.Subject = "Testmeldung von Excel2000 " & Date & Time
.Attachments.Add AWS
'Hier wird ein normaler Text erstellt
.Body = "Liebe Kolleginnen und Kollegen" & vbCrLf & vbCrLf & _
"anbei erhaltet ihr die Liste ..... " & wksBlatt.Range("K1").Value & _
"bis spätestens " & Format(Date - 4, "tt.MM.YYYY")
'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
Next wksBlatt
'Outlook schliessen
MyOutApp.Quit
'Variablen leeren
Set MyOutApp = Nothing
Set MyMessage = Nothing
End Sub
Hallo Stefan,
Danke schon mal für die schnellen Antworten.
Es soll aber erst ab Tabellenblatt 3 versendet werden. 1 und 2 sind Hilfsblätter welche nicht mit einer Mail-Adresse versehen sind.
Dadurch läuft der Code auf Fehler und als Ergebnis des folgenden Teils
Format(Date - 4, "tt.MM.YYYY"
kommt das dabei heraus.
tt43372,MM.YYYY
LG.
Peggy
Moin!
Ein englischer Tag nennt sich nun mal day:
Format(Date - 4, "dd.mm.yyyy")
Wenn die nicht benötigten Blätter 1 und 2 links stehen, kannst Du mit dem Index arbeiten:
For i = 3 To Worksheets.Count
Worksheets(i) '[…]
Next
(Ich habe mir den Code noch nicht näher angesehen)
Gruß Ralf
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
Nimm statt
ActiveSheet.Range("J1") Worksheets(I).Range("J1")
Schrieb ich aber sinngemäß bereits in meiner letzten Antwort.
Gruß Ralf
Dann kommt Laufzeitfehler 9. Index außerhalb des gültigen Bereichs!
LG.
Peggy
Sorry, hab den Fehler gefunden.
Hatte wohl vorhin zu viele Schritte rückgängig gemacht.
So funktioniert es jetzt super.
Nachdem das mit dem Einzelblatt versenden eine etwas größere Sache ist, besteht die Möglichkeit immer nur das aktuelle
Tabellenblatt eingeblendet zu lassen, so zu versenden, dann per next i zum nächsten Blatt, dieses einblenden alle anderen auszublenden, per Mail versenden usw.
Ist das umsetzbar?
Habe sonst wirklich keine andere Idee mehr.
Es soll jeder Abteilungsleiter, erst einmal nur die Liste für seine Mitarbeiter sehen.
LG.
Peggy