Arbeitsmappe aufteilen und an einzel Mail-Empfänger versenden

[RPP63]

Im im Code vermerkten Link zu https://www.online-excel.de/excel/singsel_vba.php?f=86 befindet sich ja auch ein Hinweis zum Versenden einzelner Blätter (weiter unten)!
Ich muss jetzt tatsächlich erst mal weiter arbeiten, kann Dir aber später einen angepassten Code geben, wenn Du nicht klar kommen solltest.

[Peggymaus]

Vielen Dank. Ich habe nur den oberen Code gesehen.  :92:  

Mit einem Blatt funktioniert es. Habe versucht es auf weitere Blätter zu erweitern, aber wahrscheinlich nicht an der richtigen Stelle eingefügt.
Zudem müssten wir den Code noch so abändern, dass nur die Werte mit geschickt werden und nicht die Verknüpfungen.

Im Moment schaut es so aus:

Code:

Sub Excel_Sheet_via_Outlook_Senden()
   Dim MyMessage As Object, MyOutApp As Object
   Dim SavePath As String
   Dim AWS As String
   Dim WS_Count As Integer
   Dim I As Integer
   WS_Count = ActiveWorkbook.Worksheets.Count
   For I = 3 To WS_Count
   SavePath = "C:" '"E:\Eigene Dateien"
   'Kopiert aktuelles Sheet in eine neue Mappe
   'welche nur diese Tabelle enthält
   ActiveSheet.Copy
   'Speichert die Datei unter dem Tabellennamen und einem Zeitstempel
   ActiveWorkbook.SaveAs SavePath & "\" & ActiveSheet.Name & "_" & "Mehrstunden" & Worksheets("Gesamt").Range("K1").Value & ".xlsx"
   'Mappenname wird an Variable übergeben
   'und anschliessend gleich geschlossen
   With ActiveWorkbook
       AWS = .FullName
       .Close
   End With
   'InitializeOutlook = True
   Set MyOutApp = CreateObject("Outlook.Application")
   'Nachrichtenobject erstellen
   Set MyMessage = MyOutApp.CreateItem(0)
   With MyMessage
       .To = Worksheets(I).Range("J1").Value
       .Subject = "Mehrstundenliste der " & Worksheets("Gesamt").Range("K1").Value 'Date & Time
       'Hier wird die temporär gespeicherte Datei als
       'Attachment zugefügt
       .Attachments.Add AWS
       'Hier wird eine normale Text Mail erstellt
       .Body = "Sehr geehrte Kolleginnen und Kollegen" & vbCrLf & vbCrLf & _
       "anbei erhalten Sie 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 & _
      "Marianne Musterfrau" & vbCrLf & _
      "Personalsachbearbeiterin" & vbCrLf & _
      "Tel.: 627"
       'Hier wird die HTML Mail erstellt
       '.HTMLBody = "Das ist ein Test." & vbCrLf & "Bitte ignorieren."
       'Hier wird die Mail nochmals angezeigt
       .Display
       'Hier wird die Mail gleich in den Postausgang gelegt
       .Send
       'Hier wird die temporäre Datei wieder gelöscht
       Kill AWS
   End With
   'MyOutApp.Quit
   Set MyOutApp = Nothing
   Set MyMessage = Nothing
   Next I
End Sub

LG.

Peggy

[Steffl]

Hallo,

Code:

Sub Excel_Sheet_via_Outlook_Senden()
    Dim MyMessage As Object, MyOutApp As Object
    Dim SavePath As String
    Dim AWS As String
    Dim lngC As Long
    
    SavePath = "D:" '"E:\Eigene Dateien"
    'Kopiert aktuelles Sheet in eine neue Mappe
    'welche nur diese Tabelle enthält
    For lngC = 3 To ThisWorkbook.Worksheets.Count
        Worksheets(lngC).Copy
        'Speichert die Datei unter dem Tabellennamen und einem Zeitstempel
        ActiveWorkbook.SaveAs SavePath & "\" & Worksheets(lngC).Name & "_" & Format(Now, "ddmmyyyy_hhmm") & ".xls"
        'Mappenname wird an Variable übergeben
        'und anschliessend gleich geschlossen
        With ActiveWorkbook
            AWS = .FullName
            .Close
        End With
        'InitializeOutlook = True
        Set MyOutApp = CreateObject("Outlook.Application")
        'Nachrichtenobject erstellen
        Set MyMessage = MyOutApp.CreateItem(0)
        With MyMessage
            .to = Worksheets(lngC).Range("J1").Value
            .Subject = "Testmeldung von Excel2000 "
            'Hier wird die temporär gespeicherte Datei als
            'Attachment zugefügt
            .Attachments.Add AWS
            'Hier wird eine normale Text Mail erstellt
            '.body = "Das ist ein Test" & vbCrLf & "Bitte ignorieren"
            'Hier wird die HTML Mail erstellt
            .HTMLBody = "Das ist ein Test." & vbCrLf & "Bitte ignorieren. " & Worksheets("Gesamt").Range("K1").Value & _
            "Bitte bis " & Format(Date - 4, "dd.mm.yyyy") & " erledingen."
            'Hier wird die Mail nochmals angezeigt
            .Display
            'Hier wird die Mail gleich in den Postausgang gelegt
            '.Send
            'Hier wird die temporäre Datei wieder gelöscht
            Kill AWS
        End With
    Next lngC
    MyOutApp.Quit
    Set MyOutApp = Nothing
    Set MyMessage = Nothing
End Sub

[WillWissen]

Hi Peggy,


ich habe zweimal dein Makro in Codetags gesetzt. Benutze bitte auch (zumindest bei längeren Codes) den 5. Schalter von rechts in der zweiten Iconleiste. Der Beitrag bleibt dann etwas übersichtlicher und dadurch besser lesbar.

[Peggymaus]

Vielen Dank erst einmal für Eure Hilfe,

mit viel Tüfteln habe ich es jetzt so hin bekommen, wie ich es möchte. Das schaut nun so aus:

Code:

Sub Excel_Sheet_via_Outlook_Senden()
   Dim MyMessage As Object, MyOutApp As Object
   Dim SavePath As String
   Dim AWS As String
   Dim WS_Count As Integer
   Dim I As Integer
   WS_Count = ActiveWorkbook.Worksheets.Count
   Worksheets("Vorgesetzte").Activate
   For I = 3 To WS_Count
   ActiveSheet.Next.Activate
   SavePath = "Z:\Dokumente\Fuchs" '"E:\Eigene Dateien"
   'Kopiert aktuelles Sheet in eine neue Mappe
   'welche nur diese Tabelle enthält
   With ActiveSheet.UsedRange
   .Value = .Value
   End With
   ActiveSheet.Copy
   'Speichert die Datei unter dem Tabellennamen und einem Zeitstempel
   ActiveWorkbook.SaveAs SavePath & "\" & ActiveSheet.Name & "_" & "Mehrstunden" & ActiveSheet.Range("h1").Value & ".xlsx"
   'Mappenname wird an Variable übergeben
   'und anschliessend gleich geschlossen
   With ActiveWorkbook
       AWS = .FullName
       .Close
   End With
   'InitializeOutlook = True
   Set MyOutApp = CreateObject("Outlook.Application")
   'Nachrichtenobject erstellen
   Set MyMessage = MyOutApp.CreateItem(0)
   With MyMessage
       .To = Worksheets(I).Range("J1").Value
       .Subject = "Mehrstundenliste der " & ActiveSheet.Range("h1").Value 'Date & Time
       'Hier wird die temporär gespeicherte Datei als
       'Attachment zugefügt
       .Attachments.Add AWS
       'Hier wird eine normale Text Mail erstellt
       .Body = "Sehr geehrte Kolleginnen und Kollegen" & vbCrLf & vbCrLf & _
       "anbei erhalten Sie die Mehrstundenliste der " & ActiveSheet.Range("h1").Value & _
       " mit der Bitte um Prüfung, Korrektur und Rückgabe bis spätestens  " & ActiveSheet.Range("i1").Value & "." & vbCrLf & vbCrLf & _
      "LG." & vbCrLf & vbCrLf & _
      "Marianne Musterfrau" & vbCrLf & _
      "Personalsachbearbeiterin" & vbCrLf & _
      "Tel.: 627"
       'Hier wird die HTML Mail erstellt
       '.HTMLBody = "Das ist ein Test." & vbCrLf & "Bitte ignorieren."
       'Hier wird die Mail nochmals angezeigt
       '.Display
       'Hier wird die Mail gleich in den Postausgang gelegt
       .Send
       'Hier wird die temporäre Datei wieder gelöscht
       Kill AWS
   End With
   'MyOutApp.Quit
   Set MyOutApp = Nothing
   Set MyMessage = Nothing
   Next I
End Sub

Hoffe es funktioniert dann auch noch in der Praxis.

LG.

Peggy

[WillWissen]

Du hast 'ne PN!!