1.5k Aufrufe
Gefragt in Tabellenkalkulation von
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><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
End Sub
 
 
Function test(sPath As String)
    test = CreateObject("Scripting.FileSystemObject").OpenTextFile(sPath).ReadAll()
End Function

14 Antworten

+1 Punkt
Beantwortet von m-o Profi (22.7k Punkte)

Hallo Inga,

in deiner Frage hattest du nur einen Teil des Makros gepostet, nämlich den Teil mit dem E-Mail-Versand. Der Teil mit dem Kopieren hat gefehlt. Daher war ich davon ausgegangen, dass es zum Kopieren der Daten ein eigenes Makro gibt.

Hier jetzt mal der neue bearbeitete Code, mit dem Vorschlag von Karin zum Ersetzen der 0 und 1:

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
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

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")
 
'Bildschirmaktualisierung ausschalten
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

'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
    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
       'Spalten auf optimale Breite formatieren
       .UsedRange.Columns.AutoFit
   End With
  .Close (True)                     'Änderungen speichern und schließen
End With

'hier wird die neue Datei als Anhang zugewiesen
Anhang = strVersanddatei

Set OutlookApplication = CreateObject("Outlook.Application")
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 angeforderte MinSiB Liste. </p>Bitte tragen Sie Ihre Änderungen in die <b>Spalte N</b> ein und senden die Exceltabelle per e-mail an <b>Dispo-Einkauf@Kibek.de</b> zurück.<br> Bei Rückfragen steht Ihnen das Dispositionsteam gern zur Verfügung.<p>Vielen Dank.<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)

Application.ScreenUpdating = True

End Sub

Schau mal, ob das jetzt so funktioniert, wie du willst.

Gruß

M.O.

0 Punkte
Beantwortet von colatrinker1 Einsteiger_in (33 Punkte)
Bearbeitet von colatrinker1
Hallo M.O.

es flutscht wie verrückt :-). Läuft super. Auch die Formatierung ist mit drin.

Vielen vielen Dank. Das erspart 3 Leuten eine Menge Arbeit.

Tut mir leid, dass ich das anfangs nicht richtig übermittelt habe.

Gruß,

Inga
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Inga,

freut mich, dass alles so klappt, wie du willst.

Gruß

M.O.
0 Punkte
Beantwortet von colatrinker1 Einsteiger_in (33 Punkte)

Hallo M.O. :-),

das Makro aus meiner Exceldatei aus diesem Thread ist nun leider schon wieder überholt, sodass ein etwas verändertes Makro benötigt wird. Wenn Du Zeit und Lust hast, würde ich mich über ein neues Makro freuen :-).

Hier ist die Datei: https://transfernow.net/218mr015s7eo

Das Ziel:

Es soll nur das Tabellenblatt "Filiale" (von drei unterschiedlichen Benutzern) als Anhang per e-mail (Outlock) als xls-Datei versendet werden. Aber:

- die Ziel-Datei soll keine Formel, sondern nur Werte enthalten

- die Ziel-Datei soll die Formatierung der Quell-Datei beibehalten (Querformat; Zentrierung horizontal, alle Spalten auf 1 Seite, Gitterlinien drucken, oberste Zeile fixieren, Wiederholungszeile: oberste Zeile)

- die Quell-Datei hat bedingte Farb-Formatierungen die in der Ziel-Datei beibehalten werden sollen (Spalte L + N + O)

- die Quelldatei soll unverändert bleiben.

Ich hoffe, ich habe keine Infos für mein "Wunsch-Makro" vergessen.

LG, Inga

...