per Makro Mail erstellen

[Noblesse]

Guten Tag miteinander

Ich habe eine Präsenzliste erstellt mit Makro (Button auf jedem Wochenblatt), mit dem das aktuelle Tabellenblatt als PDF den entsprechenden Mailempfänger sendet.

Nun würde ich gerne das Makro anpassen:

   OutMail.to = (fülle Adressen aus Bereich "Tabellenblatt 'Daten' A22:A27 (soweit Adressen hinterlegt sind))
   OutMail.CC = ""
   OutMail.BCC = ""
   OutMail.Subject = (fülle Text aus Zelle "Tabellenblatt 'Daten' A30")
   OutMail.Body = (fülle Text aus Zellen "Tabellenblatt 'Daten' A33:B45")

Kann mir jemand den richtigen Code nennen?

Danke und Gruss
Thomas

Code:

Sub Chef()
Dim sBlatt As String
 Dim sPdfDateiF5 As String
 Dim OutApp As Object
 Dim OutMail As Object
 
  
   ' speichern unter als PDF:
   sPdfDateiF5 = "C:\Präsenzliste.PDF"
 
   ' speichert das aktuelle Blatt (=ActiveSheet) als PDF
   ActiveSheet.ExportAsFixedFormat _
     Type:=xlTypePDF, _
     Filename:=sPdfDateiF5, _
     Quality:=xlQualityStandard, _
     IncludeDocProperties:=True, _
     IgnorePrintAreas:=False, _
     OpenAfterPublish:=False
    
   ' Bezug zu Outlook herstellen...
   Set OutApp = CreateObject("Outlook.Application")
   ' ...neue E-Mail erzeugen
   Set OutMail = OutApp.CreateItem(0)
   ' Werte den Eigenschaften zuweisen...
   OutMail.to = "noblesse@noblesse.ch" 'richtige Email-Adresse angeben
   OutMail.CC = ""
   OutMail.BCC = ""
   OutMail.Subject = "Präsenzliste Integration Intensiv"
   OutMail.Body = ""
  
   ' Anhang hinzufügen:
   OutMail.Attachments.Add sPdfDateiF5
   ' ...und abschicken
   OutMail.Send
   ' Objekte sauber auflösen
   Set OutMail = Nothing
   Set OutApp = Nothing
 
End Sub

[WillWissen]

Push

[Steffl]

Hallo,

mal ungetestet

Code:

Sub Chef()
Dim sBlatt As String
Dim sPdfDateiF5 As String
Dim OutApp As Object
Dim OutMail As Object
Dim lngC As Long
  
   ' speichern unter als PDF:
   sPdfDateiF5 = "C:\Präsenzliste.PDF"

   ' speichert das aktuelle Blatt (=ActiveSheet) als PDF
   ActiveSheet.ExportAsFixedFormat _
     Type:=xlTypePDF, _
     Filename:=sPdfDateiF5, _
     Quality:=xlQualityStandard, _
     IncludeDocProperties:=True, _
     IgnorePrintAreas:=False, _
     OpenAfterPublish:=False
    
   ' Bezug zu Outlook herstellen...
   Set OutApp = CreateObject("Outlook.Application")
   ' ...neue E-Mail erzeugen
   Set OutMail = OutApp.CreateItem(0)
   ' Werte den Eigenschaften zuweisen...
  
   For lngC = 22 To 27
     If Worksheets("Daten").Cells(lngC, 1) <> "" Then
       'OutMail.to = "noblesse@noblesse.ch" 'richtige Email-Adresse angeben
       OutMail.to = Worksheets("Daten").Cells(lngC, 1) 'richtige Email-Adresse angeben
       OutMail.CC = ""
       OutMail.BCC = ""
       OutMail.Subject = Worksheets("Daten").Cells(30, 1)
       OutMail.Body = Worksheets("Daten").Cells(33, 1).Resize(13, 2)
       ' Anhang hinzufügen:
       OutMail.Attachments.Add sPdfDateiF5
       ' ...und abschicken
       OutMail.Send
     End If
   Next lng
  
   ' Objekte sauber auflösen
   Set OutMail = Nothing
   Set OutApp = Nothing

End Sub