Sub Kopieren()
Dim rng As Range
For Each rng In Tabelle1.UsedRange.Rows
If rng.Row > 1 Then
Tabelle1.Range("AA" & CStr(rng.Row) & ":AC" & CStr(rng.Row)).Copy
Tabelle2.Range("B7").PasteSpecial xlPasteAll
Call PDF_per_EMail(Range("Tabelle1!H" & CStr(rng.Row)), Range("Tabelle1!I" & CStr(rng.Row)), "Text")
End If
Next
End Sub
Sub PDF_per_EMail(sTo As String, sBCC As String, sBody As String)
Dim strPDF As String
Dim OutlookApp As Object, strEmail As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set strEmail = OutlookApp.CreateItem(0)
Tabelle2.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "/Performance Report.pdf", Quality:=xlQualityStandard _
, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish _
:=False
strPDF = ThisWorkbook.Path & "/Performance Report.pdf"
With strEmail
.To = sTo
.BCC = sBCC
.Subject = "Performance Report"
.body = sBody
.Attachments.Add strPDF
.Display
Kill strPDF
End With
Set OutlookApp = Nothing
Set strEmail = Nothing
End Sub