Mehrer Tabellen blätter als PDF im Mail

Sub PDF_MailVB()
Dim rng As Excel.Range
Dim strMail As String
With Worksheets("Bestaetigung").Columns("B")
Set rng = .Find("x", , xlValues, xlWhole, xlByColumns, MatchCase:=False)
If Not rng Is Nothing Then
strMail = rng.Offset(0, 1).Value
Dim Name As String
Dim Datei As String
' PDF speichern mit individuellem Namen (Name + Datum)
Datei = "Bestätigung _" & Mid(Date, 1, 2) & Mid(Date, 4, 2) & Mid(Date, 9, 2) & _
"_" & Mid(Time, 1, 2) & Mid(Time, 4, 2) & Mid(Time, 7, 2) & ".pdf"
Name = ActiveWorkbook.Path + "\" + Datei
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Name, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
' Diese Datei als Mail senden per Outlook
Dim olApp As Object
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
'Empfänger
Dim Empfänger As String, Betreff As String
Dim OutApp As Object, Mail As Object, i
Dim ClpObj As DataObject
Dim Nachricht
Empfänger = strMail
Betreff = "Info"
Set ClpObj = New DataObject
Set OutApp = CreateObject("Outlook.Application")
Set Nachricht = OutApp.CreateItem(0)
With Nachricht
.To = Empfänger
.Subject = Betreff
'Betreff
.Subject = "Bestätigung" & Date & " um " & Time
'Nachricht
.Body = "text," & vbCrLf & _
"vielen Dank….." & vbCrLf & _
"Mit freundlichen Grüssen" & vbCrLf & vbCrLf & _
& vbCrLf & _
"Sinceramente vostri"
'Lesebestätigung aus
.ReadReceiptRequested = False
'Dateianhang
.Attachments.Add Name
.Display
End With
Set OutApp = Nothing
Set Nachricht = Nothing
End With
End If
End With
End Sub