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

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

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.

0 Punkte
Beantwortet von

Hallo M.O.

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

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?

 

0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
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.
0 Punkte
Beantwortet von
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.
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)

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.

0 Punkte
Beantwortet von beverly_ Experte (3.3k Punkte)

@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

0 Punkte
Beantwortet von
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
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)

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.

0 Punkte
Beantwortet von colatrinker1 Einsteiger_in (33 Punkte)

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

0 Punkte
Beantwortet von beverly_ Experte (3.3k Punkte)

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

...