Hallo zusammen
Leider funktioniert das untere Coding noch nicht so richtig. Die Daten werden nicht übertragen. Weiss nicht was mit dem coding nicht stimmt. Zusätzlich gibt es eine Fehlermeldung bei .Attachments.Add Wisst Ihr warum?
Sub RechnungErstellenUndSenden()
Dim Datum As Date
Dim Zeile As Long
Dim RechnungZeile As Long
Dim RechnungBlatt As Worksheet
Dim RechnungBereich As Range
Dim RechnungDateiname As String
Dim OutlookApp As Object
Dim OutlookMail As Object
'Datum aus Zelle A5 im Worksheet "Daten" lesen
Datum = Worksheets("Daten").Range("A5").Value
'Startzeile für Rechnung
RechnungZeile = 12
'Rechnung-Blatt und -Bereich definieren
Set RechnungBlatt = Worksheets("Rechnung")
Set RechnungBereich = RechnungBlatt.Range("A12").CurrentRegion
'Schleife durch alle Zeilen in Spalte E im Worksheet "Daten"
For Zeile = 1 To Worksheets("Daten").Cells(Rows.Count, "E").End(xlUp).Row
'Wenn das Datum in Spalte E übereinstimmt
If Worksheets("Daten").Cells(Zeile, "E").Value = Datum Then
'Zeile in Rechnung kopieren
RechnungBereich.Rows(Zeile - 11).Copy Destination:=RechnungBlatt.Rows(RechnungZeile)
'RechnungZeile erhöhen
RechnungZeile = RechnungZeile + 1
End If
Next Zeile
'Rechnung als PDF speichern
RechnungDateiname = "Rechnung_" & Format(Date, "ddmmyyyy") & ".pdf"
RechnungBereich.ExportAsFixedFormat Type:=xlTypePDF, Filename:=RechnungDateiname, Quality:=xlQualityStandard
'Outlook-App öffnen und E-Mail erstellen
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
'E-Mail-Eigenschaften festlegen
With OutlookMail
.To = "empfaenger@beispiel.com"
.Subject = "Rechnung für " & Format(Date, "dd.mm.yyyy")
.Body = "Sehr geehrte Damen und Herren," & vbNewLine & vbNewLine & "anbei erhalten Sie die Rechnung für den " & Format(Date, "dd.mm.yyyy") & "." & vbNewLine & vbNewLine & "Mit freundlichen Grüßen," & vbNewLine & "Ihr Name"
.Attachments.Add RechnungDateiname
.Display
End With
'Aufräumen
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub