Mehrere Tabellenblätter per E-Mail senden

[vanityvicious]

Hallo zusammen,

ich bin zwar neu im Forum angemeldet, habe aber als Gast schon sehr viele nützliche Posts gefunden, vielen Dank schon mal dafür! :)

Jetzt stehe ich aber doch an.
Ich sende mit untenstehenden Makro eine Tabelle als Attachment per Mail. Das funktioniert auch ganz toll, allerdings brauche ich die Tabelle 5 mal, jedes mal mit anderen Zahlen (sind Gesprächsbewertungen).
Ich hab nun ein Makro das mir für jede Bewertung ein neues TB mit fortlaufender Nummerierung erstellt (heißen immer Tabelle2 bis Tabelle6), und möchte nun dass ich diese 5 Tabellenblätter per Outlook senden kann. Also als neues Workbook, mit 5 Tabellenblättern.
Den Beitrag hier http://www.clever-excel-forum.de/thread-1303.html hier hab ich bereits gelesen, leider ist das nicht ganz das richtige für mich. Kann ich den Code den ich momentan habe entsprechend umschreiben oder ist mein Vorhaben zum Scheitern verurteilt?

Code:

Sub Mail_Callanalyse_attached()
'Working in Excel 2000-2016

   Dim Source As Range
   Dim Dest As Workbook
   Dim wb As Workbook
   Dim TempFilePath As String
   Dim TempFileName As String
   Dim FileExtStr As String
   Dim FileFormatNum As Long
   Dim OutApp As Object
   Dim OutMail As Object
   
   Empfänger = ActiveSheet.Range("C81")
   Betreff = ActiveSheet.Range("C82")
   Copy = ActiveSheet.Range("C83")
   Blincopy = ActiveSheet.Range("C84")
   

   Set Source = Nothing
   On Error Resume Next
   Set Source = Range("A1:E28").SpecialCells(xlCellTypeVisible)
   On Error GoTo 0

   If Source Is Nothing Then
       MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
       Exit Sub
   End If

   With Application
       .ScreenUpdating = False
       .EnableEvents = False
   End With

   Set wb = ActiveWorkbook
   Set Dest = Workbooks.Add(xlWBATWorksheet)

   Source.Copy
   With Dest.Sheets(1)
       .Cells(1).PasteSpecial Paste:=8
       .Cells(1).PasteSpecial Paste:=xlPasteValues
       .Cells(1).PasteSpecial Paste:=xlPasteFormats
       .Cells(1).Select
       Application.CutCopyMode = False
   End With

   TempFilePath = Environ$("temp") & "\"
   TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

   If Val(Application.Version) < 12 Then
       'You use Excel 97-2003
       FileExtStr = ".xls": FileFormatNum = -4143
   Else
       'You use Excel 2007-2016
       FileExtStr = ".xlsx": FileFormatNum = 51
   End If

   Set OutApp = CreateObject("Outlook.Application")
   Set OutMail = OutApp.CreateItem(0)

   With Dest
       .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
       On Error Resume Next
       With OutMail
           .To = Empfänger
           .CC = Copy
           .BCC = Blindcopy
           .Subject = Betreff
           .Body = ""
           .Attachments.Add Dest.FullName
           'You can add other files also like this
           '.Attachments.Add ("C:\test.txt")
           .Send   'or use .Display
       End With
       On Error GoTo 0
       .Close SaveChanges:=False
   End With

   Kill TempFilePath & TempFileName & FileExtStr

   Set OutMail = Nothing
   Set OutApp = Nothing

   With Application
       .ScreenUpdating = True
       .EnableEvents = True
   End With
End Sub

Freue mich über jede Hilfe :)

[vanityvicious]

Keiner einer Idee? :(

Hab jetzt einen Code online gefunden der so was ähnliches kann, vielleicht kann man hiermit mehr anfangen?
Würd mich wirklich über eine Antwort freuen, selbst wenn die Antwort ist dass es einfach nicht geht ;)

Code:

Sub EmailSelectedSheets()
'PURPOSE: Create email message with only Selected Worksheets attached
'SOURCE: www.TheSpreadsheetGuru.com

Dim SourceWB As Workbook
Dim DestinWB As Workbook
Dim OutlookApp As Object
Dim OutlookMessage As Object
Dim TempFileName As Variant
Dim ExternalLinks As Variant
Dim TempFilePath As String
Dim FileExtStr As String
Dim DefaultName As String
Dim UserAnswer As Long
Dim x As Long

   Empfänger = ActiveSheet.Range("C81")
   Betreff = ActiveSheet.Range("C82")
   Copy = ActiveSheet.Range("C83")
   Blindcopy = ActiveSheet.Range("C84")

'Optimize Code
 Application.ScreenUpdating = False
 Application.EnableEvents = False
 Application.DisplayAlerts = False

'Copy only selected sheets into new workbook
 Set SourceWB = ActiveWorkbook
 SourceWB.Windows(1).SelectedSheets.Copy
 Set DestinWB = ActiveWorkbook

'Check for macro code residing in
 If Val(Application.Version) >= 12 Then
   If SourceWB.FileFormat = 51 And SourceWB.HasVBProject = True Then
     UserAnswer = MsgBox("There was VBA code found in this xlsx file. " & _
       "If you proceed the VBA code will not be included in your email attachment. " & _
       "Do you wish to proceed?", vbYesNo, "VBA Code Found!")
   
   'Handle if user cancels
     If UserAnswer = vbNo Then
       DestinWB.Close SaveChanges:=False
       GoTo ExitSub
     End If
     
   End If
 End If

'Determine Temporary File Path
 TempFilePath = Environ$("temp") & "\"

'Determine Default File Name for InputBox
 If SourceWB.Saved Then
   DefaultName = Left(SourceWB.Name, InStrRev(SourceWB.Name, ".") - 1)
 Else
   DefaultName = SourceWB.Name
 End If

'Ask user for a file name
 TempFileName = Application.InputBox("What would you like to name your attachment? (No Special Characters!)", _
   "File Name", Type:=2, Default:=DefaultName)
   
   If TempFileName = False Then GoTo ExitSub 'Handle if user cancels
 
'Determine File Extension
 If SourceWB.Saved = True Then
   FileExtStr = "." & LCase(Right(SourceWB.Name, Len(SourceWB.Name) - InStrRev(SourceWB.Name, ".", , 1)))
 Else
   FileExtStr = ".xlsx"
 End If

'Break External Links
 ExternalLinks = DestinWB.LinkSources(Type:=xlLinkTypeExcelLinks)

   'Loop Through each External Link in ActiveWorkbook and Break it
     On Error Resume Next
       For x = 1 To UBound(ExternalLinks)
         DestinWB.BreakLink Name:=ExternalLinks(x), Type:=xlLinkTypeExcelLinks
       Next x
     On Error GoTo 0
     
'Save Temporary Workbook
 DestinWB.SaveCopyAs TempFilePath & TempFileName & FileExtStr

'Create Instance of Outlook
 On Error Resume Next
   Set OutlookApp = GetObject(class:="Outlook.Application") 'Handles if Outlook is already open
 Err.Clear
   If OutlookApp Is Nothing Then Set OutlookApp = CreateObject(class:="Outlook.Application") 'If not, open Outlook
   
   If Err.Number = 429 Then
     MsgBox "Outlook could not be found, aborting.", 16, "Outlook Not Found"
     GoTo ExitSub
   End If
 On Error GoTo 0

'Create a new email message
 Set OutlookMessage = OutlookApp.CreateItem(0)

'Create Outlook email with attachment
 On Error Resume Next
   With OutlookMessage
    .To = Empfänger
    .CC = Copy
    .BCC = Blindcopy
    .Subject = Betreff
    .Body = "Please see attached." & vbNewLine & vbNewLine & "Chris"
    .Attachments.Add TempFilePath & TempFileName & FileExtStr
    .Display
   End With
 On Error GoTo 0

'Close & Delete the temporary file
 DestinWB.Close SaveChanges:=False
 Kill TempFilePath & TempFileName & FileExtStr

'Clear Memory
 Set OutlookMessage = Nothing
 Set OutlookApp = Nothing
 
'Optimize Code
ExitSub:
 Application.ScreenUpdating = True
 Application.EnableEvents = True
 Application.DisplayAlerts = True

End Sub

[snb]

Einfach so

Code:

Sub M_snb()
   c01=thisworkbook.path & "\Beispiel"

   for j=1 to 5
     thisworkbook.sheets(j).copy
     with activeworkbook
         .saveas  c01 & j & ".xlsx",51
         c00=c00 & "," & .fullname
         .close 0
     end with
   next

   sn=split(mid(c00,2),",")

   with createobject("outlook.application").createitem(0)
     .to = "beispiel@.palnet.de"
     .subject = "muster"
     for j =0 to ubound(sn)
       .attachments.add sn(j)
     next
    .send
  end with
end sub