Registriert seit: 12.10.2014
Version(en): 365 Insider (32 Bit)
Im im Code vermerkten Link zu
https://www.online-excel.de/excel/singsel_vba.php?f=86 befindet sich ja auch ein Hinweis zum Versenden einzelner Blätter (weiter unten)!
Ich muss jetzt tatsächlich erst mal weiter arbeiten, kann Dir aber später einen angepassten Code geben, wenn Du nicht klar kommen solltest.
Gib einem Mann einen Fisch und du ernährst ihn für einen Tag.
Lehre einen Mann zu fischen und du ernährst ihn für sein Leben. (Konfuzius)
Registriert seit: 11.03.2015
Version(en): 2010
03.10.2018, 19:55
(Dieser Beitrag wurde zuletzt bearbeitet: 03.10.2018, 20:24 von WillWissen.
Bearbeitungsgrund: Codetags
)
Vielen Dank. Ich habe nur den oberen Code gesehen. :92:
Mit einem Blatt funktioniert es. Habe versucht es auf weitere Blätter zu erweitern, aber wahrscheinlich nicht an der richtigen Stelle eingefügt.
Zudem müssten wir den Code noch so abändern, dass nur die Werte mit geschickt werden und nicht die Verknüpfungen.
Im Moment schaut es so aus:
Code:
Sub Excel_Sheet_via_Outlook_Senden()
Dim MyMessage As Object, MyOutApp As Object
Dim SavePath As String
Dim AWS As String
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For I = 3 To WS_Count
SavePath = "C:" '"E:\Eigene Dateien"
'Kopiert aktuelles Sheet in eine neue Mappe
'welche nur diese Tabelle enthält
ActiveSheet.Copy
'Speichert die Datei unter dem Tabellennamen und einem Zeitstempel
ActiveWorkbook.SaveAs SavePath & "\" & ActiveSheet.Name & "_" & "Mehrstunden" & Worksheets("Gesamt").Range("K1").Value & ".xlsx"
'Mappenname wird an Variable übergeben
'und anschliessend gleich geschlossen
With ActiveWorkbook
AWS = .FullName
.Close
End With
'InitializeOutlook = True
Set MyOutApp = CreateObject("Outlook.Application")
'Nachrichtenobject erstellen
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.To = Worksheets(I).Range("J1").Value
.Subject = "Mehrstundenliste der " & Worksheets("Gesamt").Range("K1").Value 'Date & Time
'Hier wird die temporär gespeicherte Datei als
'Attachment zugefügt
.Attachments.Add AWS
'Hier wird eine normale Text Mail erstellt
.Body = "Sehr geehrte Kolleginnen und Kollegen" & vbCrLf & vbCrLf & _
"anbei erhalten Sie die Liste " & Worksheets("Gesamt").Range("K1").Value & _
" mit der Bitte um Prüfung, Korrektur und Rückgabe bis spätestens " & Worksheets("Gesamt").Range("L1").Value & "." & vbCrLf & vbCrLf & _
"LG." & vbCrLf & vbCrLf & _
"Marianne Musterfrau" & vbCrLf & _
"Personalsachbearbeiterin" & vbCrLf & _
"Tel.: 627"
'Hier wird die HTML Mail erstellt
'.HTMLBody = "Das ist ein Test." & vbCrLf & "Bitte ignorieren."
'Hier wird die Mail nochmals angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
.Send
'Hier wird die temporäre Datei wieder gelöscht
Kill AWS
End With
'MyOutApp.Quit
Set MyOutApp = Nothing
Set MyMessage = Nothing
Next I
End Sub
LG.
Peggy
Registriert seit: 11.04.2014
Version(en): Office 2007
Hallo,
Code:
Sub Excel_Sheet_via_Outlook_Senden()
Dim MyMessage As Object, MyOutApp As Object
Dim SavePath As String
Dim AWS As String
Dim lngC As Long
SavePath = "D:" '"E:\Eigene Dateien"
'Kopiert aktuelles Sheet in eine neue Mappe
'welche nur diese Tabelle enthält
For lngC = 3 To ThisWorkbook.Worksheets.Count
Worksheets(lngC).Copy
'Speichert die Datei unter dem Tabellennamen und einem Zeitstempel
ActiveWorkbook.SaveAs SavePath & "\" & Worksheets(lngC).Name & "_" & Format(Now, "ddmmyyyy_hhmm") & ".xls"
'Mappenname wird an Variable übergeben
'und anschliessend gleich geschlossen
With ActiveWorkbook
AWS = .FullName
.Close
End With
'InitializeOutlook = True
Set MyOutApp = CreateObject("Outlook.Application")
'Nachrichtenobject erstellen
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.to = Worksheets(lngC).Range("J1").Value
.Subject = "Testmeldung von Excel2000 "
'Hier wird die temporär gespeicherte Datei als
'Attachment zugefügt
.Attachments.Add AWS
'Hier wird eine normale Text Mail erstellt
'.body = "Das ist ein Test" & vbCrLf & "Bitte ignorieren"
'Hier wird die HTML Mail erstellt
.HTMLBody = "Das ist ein Test." & vbCrLf & "Bitte ignorieren. " & Worksheets("Gesamt").Range("K1").Value & _
"Bitte bis " & Format(Date - 4, "dd.mm.yyyy") & " erledingen."
'Hier wird die Mail nochmals angezeigt
.Display
'Hier wird die Mail gleich in den Postausgang gelegt
'.Send
'Hier wird die temporäre Datei wieder gelöscht
Kill AWS
End With
Next lngC
MyOutApp.Quit
Set MyOutApp = Nothing
Set MyMessage = Nothing
End Sub
Gruß Stefan
Win 10 / Office 2016
Registriert seit: 10.04.2014
Version(en): Microsoft 365, mtl. Kanal
Hi Peggy,
ich habe zweimal dein Makro in Codetags gesetzt. Benutze bitte auch (zumindest bei längeren Codes) den 5. Schalter von rechts in der zweiten Iconleiste. Der Beitrag bleibt dann etwas übersichtlicher und dadurch besser lesbar.
Gruß Günter
Jeder Fehler erscheint unglaublich dumm, wenn andere ihn begehen.
angebl. von Georg Christoph Lichtenberg (1742-1799)
Registriert seit: 11.03.2015
Version(en): 2010
03.10.2018, 20:33
(Dieser Beitrag wurde zuletzt bearbeitet: 03.10.2018, 20:53 von WillWissen.
Bearbeitungsgrund: Codetags
)
Vielen Dank erst einmal für Eure Hilfe,
mit viel Tüfteln habe ich es jetzt so hin bekommen, wie ich es möchte. Das schaut nun so aus:
Code:
Sub Excel_Sheet_via_Outlook_Senden()
Dim MyMessage As Object, MyOutApp As Object
Dim SavePath As String
Dim AWS As String
Dim WS_Count As Integer
Dim I As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
Worksheets("Vorgesetzte").Activate
For I = 3 To WS_Count
ActiveSheet.Next.Activate
SavePath = "Z:\Dokumente\Fuchs" '"E:\Eigene Dateien"
'Kopiert aktuelles Sheet in eine neue Mappe
'welche nur diese Tabelle enthält
With ActiveSheet.UsedRange
.Value = .Value
End With
ActiveSheet.Copy
'Speichert die Datei unter dem Tabellennamen und einem Zeitstempel
ActiveWorkbook.SaveAs SavePath & "\" & ActiveSheet.Name & "_" & "Mehrstunden" & ActiveSheet.Range("h1").Value & ".xlsx"
'Mappenname wird an Variable übergeben
'und anschliessend gleich geschlossen
With ActiveWorkbook
AWS = .FullName
.Close
End With
'InitializeOutlook = True
Set MyOutApp = CreateObject("Outlook.Application")
'Nachrichtenobject erstellen
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.To = Worksheets(I).Range("J1").Value
.Subject = "Mehrstundenliste der " & ActiveSheet.Range("h1").Value 'Date & Time
'Hier wird die temporär gespeicherte Datei als
'Attachment zugefügt
.Attachments.Add AWS
'Hier wird eine normale Text Mail erstellt
.Body = "Sehr geehrte Kolleginnen und Kollegen" & vbCrLf & vbCrLf & _
"anbei erhalten Sie die Mehrstundenliste der " & ActiveSheet.Range("h1").Value & _
" mit der Bitte um Prüfung, Korrektur und Rückgabe bis spätestens " & ActiveSheet.Range("i1").Value & "." & vbCrLf & vbCrLf & _
"LG." & vbCrLf & vbCrLf & _
"Marianne Musterfrau" & vbCrLf & _
"Personalsachbearbeiterin" & vbCrLf & _
"Tel.: 627"
'Hier wird die HTML Mail erstellt
'.HTMLBody = "Das ist ein Test." & vbCrLf & "Bitte ignorieren."
'Hier wird die Mail nochmals angezeigt
'.Display
'Hier wird die Mail gleich in den Postausgang gelegt
.Send
'Hier wird die temporäre Datei wieder gelöscht
Kill AWS
End With
'MyOutApp.Quit
Set MyOutApp = Nothing
Set MyMessage = Nothing
Next I
End Sub
Hoffe es funktioniert dann auch noch in der Praxis.
LG.
Peggy
Registriert seit: 10.04.2014
Version(en): Microsoft 365, mtl. Kanal
Du hast 'ne PN!!
Gruß Günter
Jeder Fehler erscheint unglaublich dumm, wenn andere ihn begehen.
angebl. von Georg Christoph Lichtenberg (1742-1799)