Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Arbeitsmappe aufteilen und an einzel Mail-Empfänger versenden
#1
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
Antworten Top
#2
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
Gruß Stefan
Win 10 / Office 2016
Antworten Top
#3
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
Antworten Top
#4
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
Gruß Stefan
Win 10 / Office 2016
Antworten Top
#5
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


Huh
LG.

Peggy
Antworten Top
#6
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
Gib einem Mann einen Fisch und du ernährst ihn für einen Tag. 
Lehre einen Mann zu fischen und du ernährst ihn für sein Leben. (Konfuzius)
Antworten Top
#7
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
Antworten Top
#8
Nimm statt ActiveSheet.Range("J1") Worksheets(I).Range("J1")
Schrieb ich aber sinngemäß bereits in meiner letzten Antwort. Wink

Gruß Ralf
Gib einem Mann einen Fisch und du ernährst ihn für einen Tag. 
Lehre einen Mann zu fischen und du ernährst ihn für sein Leben. (Konfuzius)
Antworten Top
#9
Dann kommt Laufzeitfehler 9. Index außerhalb des gültigen Bereichs! Huh

LG.

Peggy
Antworten Top
#10
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
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste