Wie versende ich nur ein bestimmtes Tabellenblatt statt ganze Datei als e-mail Anhang per VBA?

Question

Wie versende ich nur ein bestimmtes Tabellenblatt statt ganze Datei als e-mail Anhang per VBA?

Gefragt 6, Aug 2019 in Tabellenkalkulation von ideutz@kibek.de

Hallo Zusammen,

mein Makro läuft super. Allerdings möchte ich nicht die gesamte Datei (4 Tabellenblätter) sondern nur ein bestimmtes Tabellenblatt ("Filiale") als Mailanhang versenden.

Wie muß ich das Makro verändert?

Sub Inga()
'
' Inga Makro
'
Dim WkSh_Q As Worksheet
Dim WkSh_Z As Worksheet
Dim rZelle As Range
Dim aUeberschr As Variant
Dim iIndx As Integer
Dim iSpalte As Integer

aUeberschr = Array("Lager Nr.", "Art.-Nr.", "Art.-Bez.", "Sortimentskennzeichen", "WG", "Verfügbarer Bestand", "Summe Best. (sync, BT)", "Durchschn. Tagesabgang", "Erster Zugang", "Letzter Wareneingang", "Letzter Abgang", "Nicht disponieren", "Min. SiB")

Application.ScreenUpdating = False

Dim sPath As String
Dim strUser As String
Dim strPfad As String
Dim strSignatur As String
Dim Body As String
Dim Nachricht As Object, OutlookApplication As Object
Set OutlookApplication = CreateObject("Outlook.Application")
Dim Anhang As String
Anhang = ThisWorkbook.FullName
Set Nachricht = OutlookApplication.CreateItem(0)
With Nachricht
.To = "Empfänger eingeben"
.Subject = "MinSiB Liste"
.Attachments.Add Anhang

'Namen der Signatur definieren
strSignatur = "Standard"

strUser = Environ("Userprofile")
strPfad = strUser & "\AppData\Roaming\Microsoft\Signatures\" & strSignatur & ".htm"
.htmlBody = "<html><body>Sehr geehrte Damen und Herren,im Anhang erhalten Sie die Liste." & test(strPfad) & "</body></html>"

.Display
'.Mail.Send

End With
Set OutlookApplication = Nothing
Set Nachricht = Nothing
End Sub

Function test(sPath As String)
test = CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath).ReadAll()
End Function

14 Antworten

Seite:

Answer 1 · 2019-08-06T12:23:20+0000

Hallo,

versuch es mal so:

Sub Inga()
'
' Inga Makro
'
Dim WkSh_Q As Worksheet
Dim WkSh_Z As Worksheet
Dim rZelle As Range
Dim aUeberschr As Variant
Dim iIndx As Integer
Dim iSpalte As Integer
Dim sPath As String
Dim strUser As String
Dim strPfad As String
Dim strSignatur As String
Dim Body As String
Dim Nachricht As Object, OutlookApplication As Object
Dim Anhang As String
Dim strVersanddatei As String

aUeberschr = Array("Lager Nr.", "Art.-Nr.", "Art.-Bez.", "Sortimentskennzeichen", "WG", "Verfügbarer Bestand", "Summe Best. (sync, BT)", "Durchschn. Tagesabgang", "Erster Zugang", "Letzter Wareneingang", "Letzter Abgang", "Nicht disponieren", "Min. SiB")

Application.ScreenUpdating = False

Set OutlookApplication = CreateObject("Outlook.Application")

'Tabellenblatt Filiale in neue Arbeitsmappe kopieren
Worksheets("Filiale").Copy
'diese Arbeitsmappe temporär im Pfad des ursprünglichen Workbooks mit Namen des Tabellenblatt speichern
'dazu wird Pfad und Name in Variable hinterlegt
strVersanddatei = ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
With ActiveWorkbook
   .SaveAs strVersanddatei           'speichern
   .Close                            'schließen
End With

'hier wird die neue Datei als Anhang zugewiesen
Anhang = strVersanddatei
Set Nachricht = OutlookApplication.CreateItem(0)
With Nachricht
.To = "Empfänger eingeben"
.Subject = "MinSiB Liste"
.Attachments.Add Anhang
 
'Namen der Signatur definieren
strSignatur = "Standard"
 
strUser = Environ("Userprofile")
strPfad = strUser & "\AppData\Roaming\Microsoft\Signatures\" & strSignatur & ".htm"
.htmlBody = "<html><body><p>Sehr geehrte Damen und Herren,</p><p>im Anhang erhalten Sie die Liste.</p><p></p>" & test(strPfad) & "</body></html>"
 
.Display
'.Mail.Send
 
End With
Set OutlookApplication = Nothing
Set Nachricht = Nothing

'temporäre Datei mit einzelnem Tabellenblatt wieder löschen
Kill (strVersanddatei)

End Sub

Gruß

M.O.

Anonym · Answer 2 · 2019-08-06T13:26:40+0000

Hallo M.O.

es klappt ganz wunderbar. Vielen Dank (mal wieder).

Ich habe noch 2 Dinge, die ich gerne in dem Makro hätte. Vielleicht kannst Du dabei helfen?

Wenn in der Ziel-Tabelle (Filiale) in der Spalte "Nicht disponieren" eine 0 steht, soll der Text "Dispo" geschrieben werden und wenn eine 1 darin steht, soll der Text "nicht dispo" erscheinen.

Geht das auch?

Answer 3 · 2019-08-06T13:57:19+0000

Hallo,

wo in der Spalte "Nicht disponieren" steht denn die 0 bzw. die 1 (z.B. in der 2. Zeile)? Und wo soll denn der Text dann hingeschrieben werden?

Gruß

M.O.

Anonym · Answer 4 · 2019-08-06T14:19:57+0000

Sorry, ich habe nicht gut erklärt.

Im Tabellenblatt Logomate Quelle werden die Quelldaten hineinkopiert. Die erste Zeile hat Überschriften. In irgendeiner Spalte der 1. Zeile (Überschrift) steht "Nicht disponieren". Ab der 2. Zeile ist eine 0 oder 1 möglich.

Mit dem Makro werden verschiedene Spalten in das Tabellenblatt "Filiale" geschrieben. Unter anderem auch die Spalte "Nicht disponieren". In der Zieltabelle "Filiale" befindet sich in Spalte L die Überschrift "Nicht disponieren". Aber der 2. Zeile der Spalte L fangen dann die 0 bzw. 1 an, die in Dispo bzw. nicht Dispo ersetzt werden sollen.

hoffe, jetzt ist es verständlicher.

Answer 5 · 2019-08-07T06:10:14+0000

Hallo,

schau mal, ob das so funktioniert, wie du willst:

Sub Inga()
'
' Inga Makro
'
Dim WkSh_Q As Worksheet
Dim WkSh_Z As Worksheet
Dim rZelle As Range
Dim aUeberschr As Variant
Dim iIndx As Integer
Dim iSpalte As Integer
Dim sPath As String
Dim strUser As String
Dim strPfad As String
Dim strSignatur As String
Dim Body As String
Dim Nachricht As Object, OutlookApplication As Object
Dim Anhang As String
Dim strVersanddatei As String
Dim lngLetzte As Long
Dim lngZeile As Long

aUeberschr = Array("Lager Nr.", "Art.-Nr.", "Art.-Bez.", "Sortimentskennzeichen", "WG", "Verfügbarer Bestand", "Summe Best. (sync, BT)", "Durchschn. Tagesabgang", "Erster Zugang", "Letzter Wareneingang", "Letzter Abgang", "Nicht disponieren", "Min. SiB")

Application.ScreenUpdating = False

Set OutlookApplication = CreateObject("Outlook.Application")

'Tabellenblatt Filiale in neues Workbook kopieren
Worksheets("Filiale").Copy
'dieses Workbook temporär im Pfad des ursprünglichen Workbooks mit Namen des Tabellenblatt speichern
'dazu wird Pfad und Name in Variable hinterlegt
strVersanddatei = ThisWorkbook.Path & "\" & ActiveSheet.Name & ".xlsx"
With ActiveWorkbook
   .SaveAs strVersanddatei           'speichern
   'in Spalte L die Werte 0 und 1 ersetzen
   'dazu erst einmal die letzte beschriebene Zeile ermitteln
   With Worksheets(1)
     lngLetzte = .Cells(Rows.Count, 12).End(xlUp).Row
     For lngZeile = 2 To lngLetzte
       If .Cells(lngZeile, 12) = 0 Then .Cells(lngZeile, 12) = "Dispo"
       If .Cells(lngZeile, 12) = 1 Then .Cells(lngZeile, 12) = "nicht Dispo"
       Next lngZeile
   End With
  .Close (True)                     'Änderungen speichern und schließen
End With

'hier wird die neue Datei als Anhang zugewiesen
Anhang = strVersanddatei
Set Nachricht = OutlookApplication.CreateItem(0)
With Nachricht
.To = "Empfänger eingeben"
.Subject = "MinSiB Liste"
.Attachments.Add Anhang
 
'Namen der Signatur definieren
strSignatur = "Standard"
 
strUser = Environ("Userprofile")
strPfad = strUser & "\AppData\Roaming\Microsoft\Signatures\" & strSignatur & ".htm"
.htmlBody = "<html><body><p>Sehr geehrte Damen und Herren,</p><p>im Anhang erhalten Sie die Liste.</p><p></p>" & test(strPfad) & "</body></html>"
 
.Display
'.Mail.Send
 
End With
Set OutlookApplication = Nothing
Set Nachricht = Nothing

'temporäre Datei mit einzelnem Tabellenblatt wieder löschen
Kill (strVersanddatei)

End Sub

Gruß

M.O.

Answer 6 · 2019-08-07T08:24:50+0000

@All,

das Ersetzen der 0 und 1 lässt sich auch auf einen Ritt erledigen ohne dass man eine Schleife benutzt:

    With Worksheets(1)
        .Columns(12).Replace What:="0", Replacement:="""nicht Dispo""", LookAt:= _
            xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        .Columns(12).Replace What:="1", Replacement:="""Dispo""", LookAt:= _
            xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    End With

Bis später, Karin

Anonym · Answer 7 · 2019-08-07T09:40:20+0000

Hallo M.O., hallo Karin,

vielen lieben Dank für Euer Feedback.

Das kopieren der Daten von dem Quell-Tabellenblatt "Logomate Quelle" auf das Ziel-Tabellenblatt "Filiale" klappt leider nicht.

Befinden sich schon Daten im Ziel-Tabellenblatt, klappt es ganz wunderbar.

@ Karin: Dankeschön. Ich weiß leider nicht, an welcher Stelle dieser Teil ersetzt wird.

Gruß, Inga

Answer 8 · 2019-08-07T11:08:14+0000

Hallo Inga,

du schreibst

Das kopieren der Daten von dem Quell-Tabellenblatt "Logomate Quelle" auf das Ziel-Tabellenblatt "Filiale" klappt leider nicht.

Geht das nicht über einen besonderen Code (so hatte ich es verstanden)? Vorher hattest du ja geschrieben:

Mit dem Makro werden verschiedene Spalten in das Tabellenblatt "Filiale" geschrieben. Unter anderem auch die Spalte "Nicht disponieren".

Und dein gepostestes Makro genereriert ja nur die Mail.

Gruß

M.O.

Answer 9 · 2019-08-07T12:13:18+0000

Hallo M.O.

danke, für deine Geduld mit mir..

Also bei dem (ursprünglichen) Code, klappt das Kopieren von Quell-Tabelle in Zieltabelle.

Sub LM()
'
' LM Makro
'
Dim WkSh_Q As Worksheet
Dim WkSh_Z As Worksheet
Dim rZelle As Range
Dim aUeberschr As Variant
Dim iIndx As Integer
Dim iSpalte As Integer

aUeberschr = Array("Lager Nr.", "Art.-Nr.", "Art.-Bez.", "Sortimentskennzeichen", "WG", "Verfügbarer Bestand", "Summe Best. (sync, BT)", "Durchschn. Tagesabgang", "Erster Zugang", "Letzter Wareneingang", "Letzter Abgang", "Nicht disponieren", "Min. SiB")

Application.ScreenUpdating = False
Set WkSh_Q = Worksheets("Logomate Quelle") ' das Quell-Tabellenblatt
Set WkSh_Z = Worksheets("Filiale") ' das Ziel-Tabellenblatt

With WkSh_Q.Rows(1)
For iIndx = 0 To UBound(aUeberschr)
Set rZelle = .Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:=xlValues)
If Not rZelle Is Nothing Then
iSpalte = iSpalte + 1
WkSh_Q.Columns(rZelle.Column).Copy Destination:=WkSh_Z.Columns(iSpalte)
End If
Next iIndx
End With

Application.ScreenUpdating = True

Dim sPath As String
Dim strUser As String
Dim strPfad As String
Dim strSignatur As String
Dim Body As String
Dim Nachricht As Object, OutlookApplication As Object
Set OutlookApplication = CreateObject("Outlook.Application")
Dim Anhang As String
Anhang = ThisWorkbook.FullName
Set Nachricht = OutlookApplication.CreateItem(0)
With Nachricht
.To = "Empfänger eingeben"
.Subject = "MinSiB Liste"
.Attachments.Add Anhang

'Namen der Signatur definieren
strSignatur = "Standard"

strUser = Environ("Userprofile")
strPfad = strUser & "\AppData\Roaming\Microsoft\Signatures\" & strSignatur & ".htm"
.htmlBody = "<html><body>Sehr geehrte Damen und Herren,im Anhang erhalten Sie die angeforderte MinSiB Liste. Bitte tragen Sie Ihre Änderungen in die Spalte N ein und senden die Exceltabelle per e-mail an Dispo-Einkauf@Kibek.de zurück. Bei Rückfragen steht Ihnen das Dispositionsteam gern zur Verfügung.Vielen Dank." & test(strPfad) & "</body></html>"

.Display
'.Mail.Send

End With
Set OutlookApplication = Nothing
Set Nachricht = Nothing
End Sub

Function test(sPath As String)
test = CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath).ReadAll()
End Function

Was in den Ursprungscode fehlt:

- Im Zieltabellenblatt "Filiale" (dorthin sollen die Quelldaten eingefügt werden) soll die Spalte "Nicht disponieren" (Spalte L) ab Zeile 2 mit den Inhalten von 0 durch "Dispo" oder 1 durch "nicht Dispo" ersetzt werden. Das Zieltabellenblatt soll überschrieben werden (sofern Daten vorhanden sind), wenn neue Daten in der Quelldatei "Logomate Quelle" sind und das Makro ausgelöst wird.

- Statt der gesamten Datei soll nur das Zieltabellenblatt "Filiale" an den Mailanhang gehängt werden.

- schön wäre noch, wenn die Spaltenbreite im Zieltabellenblatt auf die optimale Breite formatiert werden könnte.

Soll ich die Datei mal zusenden?

LG, Inga

Answer 10 · 2019-08-07T12:53:17+0000

Hi Inga,

ersetze die folgenden Zeilen durch meinen Code:

   With Worksheets(1)
     lngLetzte = .Cells(Rows.Count, 12).End(xlUp).Row
     For lngZeile = 2 To lngLetzte
       If .Cells(lngZeile, 12) = 0 Then .Cells(lngZeile, 12) = "Dispo"
       If .Cells(lngZeile, 12) = 1 Then .Cells(lngZeile, 12) = "nicht Dispo"
       Next lngZeile
   End With

Bis später, Karin

Wie versende ich nur ein bestimmtes Tabellenblatt statt ganze Datei als e-mail Anhang per VBA?

14 Antworten

Deine Antwort

Beliebteste Themen