(Excel) / 2 Dateien anhängen an Email

jerry0110

Erfahrenes Mitglied
Hallo zusammen,

ich habe folgenden Code gefunden und angepasst. Der Code war für einen Anhang gedacht und ich habe diesen jetzt abgeändert nach meinem Verständnis um eine 2te Datei anzuhängen. Es muss leider eine 2te Datei sind und nicht eine Datei mit den 2 ausgewählten Sheets.

Visual Basic:
Sub EMail()
Dim strBlatt As String
Dim strDatei As String
Dim strPfad As String
Dim outObj As Object
Dim Mail As Object
Dim strBlatt2 As String
Dim strDatei2 As String
Dim strBodyText As String
Dim strPfad2 As String
Dim myDate As Date

myDate = datum

ThisWorkbook.Worksheets("Ja").Activate

Set outObj = CreateObject("Outlook.Application")
Set Mail = outObj.CreateItem(0)
'** Pfad für temporäre Zwischenspeicherung angeben
strPfad = "C:\Temp" 'entsprechend anpassen
'** Aktuelles aktives Blatt in neue Arbeitsmappe kopieren
strBlatt = ActiveSheet.Name
'** Gewähltes Tabellenblatt kopieren
Sheets(strBlatt).Copy
'** Blatt temporär in vorgegebenes Verzeichnis abspeichern
ActiveWorkbook.SaveAs strPfad & "\" & Format(myDate, "DD.MM.YYYY") & "_Ja.xls"
'** Pfad und Dateiname der neuen Datei zwischenspeichern
strDatei = strPfad & "\" & Format(myDate, "DD.MM.YYYY") & "_Ja.xls"


ThisWorkbook.Worksheets("Gesamt").Activate

'** Aktuelles aktives Blatt in neue Arbeitsmappe kopieren
strBlatt2 = ActiveSheet.Name
'** Gewähltes Tabellenblatt kopieren
Sheets(strBlatt2).Copy
'** Blatt temporär in vorgegebenes Verzeichnis abspeichern
ActiveWorkbook.SaveAs strPfad2 & "\" & Format(myDate, "DD.MM.YYYY") & "_Gesamt.xls"
'** Pfad und Dateiname der neuen Datei zwischenspeichern
strDatei2 = strPfad2 & "\" & Format(myDate, "DD.MM.YYYY") & "_Gesamt.xls"


'** Body-Text festlegen
strBodyText =

'** Mail erzeugen
With Mail
.SentOnBehalfOfName = ""
.To = ""
.CC = ""
.Subject = ""  'Betreff
.BodyFormat = 1 '2 = HTML, 1 = Text
.Attachments.Add strDatei & strDatei2 'Anhang
.Body = strBodyText 'Bodytext / Signatur
End With

'** Erzeugte Datei schließen
Workbooks(Dir(strDatei)).Close
Workbooks(Dir(strDatei2)).Close

'** Erzeugte Datei wieder löschen
Kill (strDatei)
Kill (strDatei2)

'** E-Mail anzeigen
Mail.Display
End Sub

Natürlich funktioniert es nicht. Bei einem Anhang funktioniert es ohne Probleme.

Habe zwar noch eine If Schleif drin:

Visual Basic:
If ThisWorkbook.Sheets("Gesamt").Range("C2").Text = "" Then Exit Sub

Aber die verhindert ja nur, wenn die Tabelle nicht gefüllt ist, dass er keine Email erzeugt.
 
Zuletzt bearbeitet von einem Moderator:
Ich habe bei deinem Beitrag die code Tags durch code=vb Tags ersetzt

Mal noch unabhängig vom Problem
item:
Visual Basic:
ActiveWorkbook.SaveAs strPfad & "\" & Format(myDate, "DD.MM.YYYY") & "_Ja.xls"
'** Pfad und Dateiname der neuen Datei zwischenspeichern
strDatei = strPfad & "\" & Format(myDate, "DD.MM.YYYY") & "_Ja.xls"
Mööööp. Anders herum. Denn Doppelt gemoppelt ist immer Fehleranfällig
Visual Basic:
'** Pfad und Dateiname der neuen Datei zwischenspeichern
strDatei = strPfad & "\" & Format(myDate, "DD.MM.YYYY") & "_Ja.xls"
ActiveWorkbook.SaveAs strDatei

item: Zuerst wählst du gezielt das Sheet "Ja" aus, dann machst du das folgende:
strBlatt = ActiveSheet.Name

Mach es auch hier umgekehrt

Item: Des weiteren. Arbeite nicht mit activeSheets etc. Das führt zu Chaos.

item; Du kopierst das aktive Sheet in die aktive Arbeitsmappe und speicherst das ganze. Dadurch hast du einfach einen Arbeitsmappe, in dem das Sheet "Ja" doppelt drin ist.

Versteh ich das Richtig, du hast eine Arbeitsmappe mit 2 Sheets. Diese sollen jeweils in eine eigene Datei ausgelagert werden, welche dann versendet werden.
Mein Vorschlag dazu
Visual Basic:
'SETTINGS
Private Const C_TEMP_PATH = "C:\Temp"   'entsprechend anpassen
Private Const C_EXCEL_FORMAT = xlExcel8 'Dateiformat siehe auch das Property fileExtension weiter unten

Public Sub EMail()
    Dim filePaths(1) As String 'Definieren wieviel Dateien es sind. Index beginnt bei 0
    Dim outObj As Object
    Dim mail As Object
    Dim i As Integer
    
    'Alle Shhets exportieren
    filePaths(0) = extractWs("Ja")
    filePaths(1) = extractWs("Gesamt")
    
    'Mail erstellen
    Set outObj = CreateObject("Outlook.Application")
    Set mail = outObj.CreateItem(0)
    
    With mail
        .BodyFormat = 1 '2 = HTML, 1 = Text
        'Die Dateien anhängen
        For i = 0 To UBound(filePaths)
            .Attachments.Add filePaths(i)
        Next i
        .Body = strBodyText 'Bodytext / Signatur
    End With

    '** Erzeugte Datei wieder löschen
    For i = 0 To UBound(filePaths)
        cFso.DeleteFile filePaths(i), True
    Next i

    '** E-Mail anzeigen
    mail.Display
   
End Sub

'/**
' * Extrahiert ein Sheet in ein neues Workbook
' * @param  String  Name des Worksheets
' * @return String  Pfad des neuen Workbooks
' */
Private Function extractWs(ByRef iWsName As String) As String
    Dim wb As Workbook
    'Pfad zusammenstellen
    extractWs = cFso.BuildPath(C_TEMP_PATH, Format(Now, "DD.MM.YYYY") & "_" & iWsName & fileExtension)
    
    'Sicherstellen, dass die Datei nicht bereits existiert
    If cFso.FileExists(extractWs) Then cFso.DeleteFile extractWs, True
    
    'Neues Workbook anlegen
    Set wb = Application.Workbooks.Add()
    'Sheet kopieren
    ThisWorkbook.Worksheets(iWsName).Copy Before:=wb.Sheets(1)
    'Leere Sheets im Workbook entfernen (Die werden von Excel selber erstellt
    Application.DisplayAlerts = False
    Do While wb.Worksheets.Count > 1
        wb.Worksheets(wb.Worksheets.Count).Delete
    Loop
    Application.DisplayAlerts = True
            
    'Neues Workbook speichern und schliessen
    wb.SaveAs extractWs, C_EXCEL_FORMAT
    wb.Close
    Set wb = Nothing
End Function
    
'/**
' * Gibt ein FileSystemObject zurück
' * @return FileSystemObject
' */
Private Property Get cFso() As Object
    Static cachedObj As Object:    If cachedObj Is Nothing Then Set cachedObj = CreateObject("Scripting.FileSystemObject")
    Set cFso = cachedObj
End Property

'/**
' * Gibt anhand des XlFileFormat die Dateiendung zurück
' * @return String
' */
Private Property Get fileExtension() As String
    Select Case C_EXCEL_FORMAT
        Case xlOpenXMLWorkbook:             fileExtension = ".xlsx"          '51 (without macro's in 2007-2013, xlsx)
        Case xlExcel8:                      fileExtension = ".xls"           '56(97-2003 format in Excel 2007-2013, xls)
    End Select
End Property
 
Zuletzt bearbeitet:
Also was ich jetzt gemacht habe ist, dass ich mydate eingefügt gabe, da ich ja das Datum durch eine Funktion berechnen lasse.
Ich habe das & "_" & weggenommen, weil ich jetzt die Sheetnamen gleich den Dateinamen angepasst habe.

Code:
Private Function extractWs(ByRef iWsName As String) As String
    Dim wb As Workbook
    Dim mydate As Date
    mydate = datum
    'Pfad zusammenstellen
   extractWs = cFso.BuildPath(C_TEMP_PATH, Format(mydate, "DD.MM.YYYY") & iWsName & fileExtension)      <----- angepasst
 
    'Sicherstellen, dass die Datei nicht bereits existiert
   If cFso.FileExists(extractWs) Then cFso.DeleteFile extractWs, True
 
    'Neues Workbook anlegen
   Set wb = Application.Workbooks.Add()
    'Sheet kopieren
   ThisWorkbook.Worksheets(iWsName).Copy Before:=wb.Sheets(1)
    'Leere Sheets im Workbook entfernen (Die werden von Excel selber erstellt
   Application.DisplayAlerts = False
    Do While wb.Worksheets.Count > 1
        wb.Worksheets(wb.Worksheets.Count).Delete
    Loop
    Application.DisplayAlerts = True
         
    'Neues Workbook speichern und schliessen
   wb.SaveAs extractWs, C_EXCEL_FORMAT
    wb.Close
    Set wb = Nothing
End Function

Und bei der Mail habe ich dann entsprechende alles angepasst:

Code:
Private Sub EMail_HPF()
    Dim filePaths(1) As String 'Definieren wieviel Dateien es sind. Index beginnt bei 0
    Dim outObj As Object
    Dim mail As Object
    Dim i As Integer
    Dim mydate As Date
    Dim strBodyText As String
    mydate = datum
 
    'Alle Shhets exportieren
    filePaths(0) = extractWs("_Gesamt")
    filePaths(1) = extractWs("_Ja")
 
    'Mail erstellen
    Set outObj = CreateObject("Outlook.Application")
    Set mail = outObj.CreateItem(0)
  
    '** Body-Text festlegen
   strBodyText = _
    "Sehr geehrte Damen und Herren,"

  
 
    With mail
        .BodyFormat = 1 '2 = HTML, 1 = Text
       'Die Dateien anhängen
       For i = 0 To UBound(filePaths)
            .Attachments.Add filePaths(i)
        Next i
        .Body = strBodyText 'Bodytext / Signatur
        .SentOnBehalfOfName = ""
        .To = ""
        .CC = ""
        .Subject = "Ergebnisse vom " & Format(mydate, "DD.MM.YYYY") 'Betreff
   End With
    '** Erzeugte Datei wieder löschen
   For i = 0 To UBound(filePaths)
        cFso.DeleteFile filePaths(i), True
    Next i
    '** E-Mail anzeigen
   mail.Display
 
End Sub

Jetzt kommt bei der Funktion die Fehlermeldung das der Bereich nicht gefunden werden kann. Was mir ja eigentlich sagt, dass er den Pfad nicht findet mit der Datei.
 
Und wo kommt die Fehlermeldung?

Zudem
mydate = datum
Woher kommt die Variable datum? Ist das ein Named-Range? Oder eine Variable die du irgendwo abgelegt hast?
 
mydate = datum kommt von der Funktion:

Code:
Private Function datum() As Date
    If Weekday(Date, vbMonday) = 1 Then
        datum = Date - 3
    Else
        datum = Date - 1
    End If
End Function

Und die Fehlermeldung kommt hier:

Code:
    'Sheet kopieren
   ThisWorkbook.Worksheets(iWsName).Copy Before:=wb.Sheets(1)
 
Heisst dein Sheet auch wirklich "_Ja"?
Wenn nicht, dann hat dort der _ nix verloren. In den folgenden Zeilen muss der genaue SheetName stehen. Sonst findet er sie nicht
Visual Basic:
    filePaths(0) = extractWs("_Gesamt")
    filePaths(1) = extractWs("_Ja")
 
:( Ich bin so.....!!
Hab natürlich da einen Fehler. Sorry.

Habe aber noch eine Frage zum anhängen der Datei.
Ich habe beim Speichern, vorher im Script, eine If Abfrage, die in einem Feld guckt ob es befüllt ist.
Wenn nicht speichert er die Datei nicht.

Kann ich das auch bei der Email machen? Wenn das Feld leer ist, dann soll er die Datei auch nicht anhängen.

Und kann ich theoretisch eine Datei als pdf und eine als Excel schicken?
 
Schau dass der Rückgabewert der Funktion extractWs() ein leerer String ist, wenn nicht exportiert wird.
Darauf kannst du nachher prüfen

Visual Basic:
Private Function extractWs(ByRef iWsName As String) As String
    Dim doExport As Boolen   
     ...

    doExport = Meine Bedinung

     If doExport Then
        TODO: Exportieren
    else
        extractWs = ""
    End If
    ...
End Function

Visual Basic:
       For i = 0 To UBound(filePaths)
            If  filePaths(i) <> "" Then .Attachments.Add filePaths(i)
        Next i
 
Ich habe das ein wenig anders gelöst.
Das Makro läuft so ab, dass ich am Anfang schon alle Sheets erstelle mit Überschrift.
Wenn er dann alles aus der Hauptdatei in die Sheets sortiert abgelegt habe, speichert er die Daten.
Da prüfe ich schon ob im Feld unter der Überschrift was steht. Wenn nicht, dann speichert er nicht.
Das gleich hatte ich auch bei der Email. Wenn dort nix steht, dann exportier nix und erstell keine Email.
 
Keine Ahnung was du damit meinst. Du musst einfach schauen, das entweder der Array nicht grösser ist als die Anzahl Dateien die wirklich versendet werden, oder dass du beim Anhängen prüfst, ob da auch eine Datei vorhanden ist.

Wenn ich dein Code sehen würde, könnte ich ev. besser helfen
 
Zurück