Hallo,
ich komme irgendwie nicht weiter.
Ich möchte gerne eine Info Mail per Makro verschicken.
Dazu möchte ich das Makro ausführen, dann soll an alle Mailadressen in der Tabelle ( Spalte R )
eine Mail versand werden in der als Anlage eine Tabelle steht sie vom Aufbau genauso wie die Ursprungstabelle ist.
In dieser Tabelle sollen aber nur alle Werte/ Daten enthalten sein die in der selben Zeile wie die Mailadresse stehen.
Es sollte sich bei Outlook ein Mailfenster mit einem bestimmten Textbaustein aufmachen, dass ich dann nur noch mit der Anlage abschicke, oder sich auotmatisch verschickt.
07.12.2014, 10:59 (Dieser Beitrag wurde zuletzt bearbeitet: 07.12.2014, 11:01 von Rabe.)
(07.12.2014, 07:40)Steffl schrieb: aber vielleicht kannst Du es nach diesem Link lösen.
Wenn der Tabellen-Zeilen-Inhalt nicht als Datei-Anhang sein muß, geht es vielleicht mit dem 2. Makro auf der letzten Seite des Links, angepasst an die Datei (ungetestet):
Code:
Option Explicit
Sub Send_OriginalRange_from_Excel()
Dim i As Integer
'Geht nur ab Office 2000 und höher
For i = 3 To 22
'Ohne Select geht es in diesem Fall nicht :-))
Range("A" & i & ":R" & i).Select
'Das anzeigen der Envelope Commandbar ist unabdingbar
'Hier wird EXCEL selbst als "Mail-Client" verwendet.
ActiveWorkbook.EnvelopeVisible = True
'Nun werden die Adressen vergeben
With ActiveSheet.MailEnvelope
'Dies ist der Betreff
.Item.Subject = "Die aktuellen Daten"
'Dies ist der eigentlich "Body"-Text
.Introduction = "Das ist der Einleitungstext." & vbCrLf & "mit einer zweiten Zeile"
'Die Empfänger stehen in Spalte R ab Zeile 3
.Item.To = Cells(i, 18) 'E-Mail Adresse
.Item.Send
End With
Next i
ActiveWorkbook.EnvelopeVisible = False
End Sub
07.12.2014, 11:10 (Dieser Beitrag wurde zuletzt bearbeitet: 07.12.2014, 11:14 von schauan.)
Hallo Thomas,
im Prinzip geht es als Alternative zu Ralfs Vorschlag unter direkter Verwendung von Outlook fuer einen Adressaten so. Fuer mehrere Kann man noch eine Schleife drum bauen.
Deine Datei geht übrigens herunter zu laden, da ist aber noch kein Makro drin.
Code:
Option Explicit
Sub SendSheet()
'Variablendeklarationen
'Objekte
Dim objWb As Workbook
Dim olApp As Object
Dim objMail As Object
'String
Dim strTempFName As String
'neues Outlook Objekt zuweisen
Set olApp = CreateObject("Outlook.Application")
'olApp.Session.Logon
'Blatt kopieren als neue Mappe
ActiveSheet.Copy
'Arbeitsmappe Objekt zuweisen
Set objWb = ActiveWorkbook
'Name fuer temporaere Datei aus Blattname und Zusaetzen
strTempFName = ActiveSheet.Name & "_ToSend_" & Format(Now, "dd-mmm-yy_h-mm-ss")
'Email erstellen
Set objMail = olApp.CreateItem(0)
'Mit der Mappe
With objWb
.SaveAs "C:\Test\" & strTempFName & ".xlsx", FileFormat:=51
'On Error Resume Next
'mit dem email
With objMail
'an, auf Tabelle Liste Namen Zelle R3
.To = Sheets("Liste Namen").Cells(3, 18).Value
'.CC = ""
'.BCC = ""
'Betreff
.Subject = "Warum und wieso"
'Textkoerper
.Body = "Um was geht's eigentlich?"
'Anhang hinzufuegen
.Attachments.Add objWb.FullName
'email anzeigen
.Display
'Ende mit dem email
End With
'On Error GoTo 0
'Schliessen der Mappe ohne Speichern
.Close SaveChanges:=False
'Ende Mit der Mappe
End With
'Mailobjekt zuruecksetzen
Set objMail = Nothing
'Kill "C:\Test\" & strTempFName & ".xlsx"
'Outlookobjekt zuruecksetzen
Set olApp = Nothing
End Sub
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)
Hallo Andrè,
danke erstmal,
Vom Grund her läuft es.
Aber es wird die ganze Tabelle einfach nur kopiert und der Mail angehängt.
Das Problem dabei ist, dass dies ein Tabelle für Personen ist wo alle möglichen Daten enthalten sind.
Diese Personen bekommen einmal pro Jahr nur Ihre Daten per Mail zugesendet und Korrigieren diese dann oder auch nicht.
Von daher darf der Mailadresse aus Zeile 2 nur der Inhalt aus Zeile 2 gesand werden.
bei den weiteren Zeilen genauso.
Die einzelnen Tabellen brauchen auch nicht gespeichert werden. Die Daten hab ich ja noch in der Ursprungstabelle.
Wie bekomme ich meinen längeren Text in den Textkörper Body.
Es sind ein paar Absätze drin und kommas (kommata oder wie auch immer) und Punkte.
Egal wie ich es zusammenführe habe ich Syntaxfehler oder andere Fenster die aufpoppen.
Zitat:Lieber Kollege,
mit dieser Mail informiere ich dich und bitte dich gleichzeitig um einen Abgleich der Daten.
.
Folgende Daten sind beim XXXX gespeichert und in der angehängten Exel-Datei einsehbar.
Ich bitte euch diese Daten zu ergänzen oder zu korrigieren.
Wichtig sind für mich die aktuellen Telefonnummern und E-Mailadressen.
Diese Informationen sind für eine sauber und vollständig geführte Liste notwendig und werden von mir absolut vertraulich behandelt.
Ebenso steht dort die Gültigkeit der Lizenz und ihr könnt sehen ob ihr zur Fortbildung müsst.
Wenn etwas an den Daten nicht korrekt sein sollte, dann ändert es bitte in der Tabelle mit der Schriftfarbe rot (Speichern bitte nicht vergessen) und schickt mir die Datei im Anhang zurück.
Sind die Daten so in Ordnung, bitte ich euch, mir auf meine Mail, mit „alles in Ordnung“ zu antworten.
Alle Lizenzen sind nach der DVO zwei Jahre gültig ab Erwerb (Bestehen der praktischen Prüfung) bzw. ab der letzten besuchten Fortbildung. Die Gültigkeit einer Lizenz endet immer zum 31.12. des entsprechenden Jahres.
Zum Lizenzerhalt muss eine Fortbildung besucht werden – spätestens alle zwei Jahre. Verlängert werden bei Besuch von Fortbildungen ausschließlich Lizenzen, die zum Zeitpunkt der Fortbildung in dem Vorjahr abgelaufen sind. Läuft eine Lizenz zum Beispiel zum 31.12.2014 ab, dann muss die Fortbildung im Frühjahr 2015 besucht werden, da ab dem 01.01.2015 diese Lizenz schon ungültig geworden ist.
Fortbildungen für Schiedsrichter finden pro Jahr einmal statt.
Die Termine werden frühzeitig bekannt gegeben.
Alternativ können schiedsrichterspezifische Fortbildungsveranstaltungen anderer Verbände anerkannt werden. Dazu bitte bei mir eine entsprechende Teilnahmebestätigung per E-Mail einreichen.
Kann eine zur Lizenzverlängerung notwendige Fortbildung nicht besucht werden, so kann die Fortbildungspflicht einmal „geschoben“ werden. Dazu muss – vor dem Gültigkeitsablauf der Lizenz - ein schriftlicher (formloser) Antrag an den Schiedsrichter-Obmann gestellt werden. Rückwirkende Anträge sind nicht möglich.
Bitte beachte, dass diese Regelungen dazu gedacht sind, ein hohes Qualitätsniveau in den Spielklassen zu erreichen. Engagierte Schiedsrichter bilden sich jährlich fort
Für den Fall, dass eine Lizenz mit Ablauf des Jahres ungültig wird, gib mir bitte bis spätestens 31.12. Bescheid, ob an einer Verlängerung Interesse beststeht. Höre ich nichts von dir, werden wir die Lizenz-Nummer mit Ablauf des Jahres leider zur Neuvergabe freigeben müssen.
Mit freundlichen Grüßen,
Thomas Albrecht
Und wie wird die Schleife eingabaut?
Sind dann zwar ca. hundert mails und es dauert etwas aber Zeit spart es trotzdem.
Ich hoffe da war jetzt nicht zuviel auf einmal.
07.12.2014, 20:47 (Dieser Beitrag wurde zuletzt bearbeitet: 07.12.2014, 20:48 von schauan.)
Hallo Thomas,
da hab ich erst mal die Aufgabe umgesetzt:
Zitat:eine Mail versand werden in der als Anlage eine Tabelle steht sie vom Aufbau genauso wie die Ursprungstabelle ist.
Wenn die Daten aus der Tabelle direkt in den Body sollen und kein Anhang dran, dann kannst Du es eventuell so machen. Im Body habe ich jetzt erst mal die Inhalte von A3, B3 und C3. Die könnte bzw. sollte man aber an anderer Stelle zusammenfassen. Ich hab das jetzt nicht getestet, den code nur hier gekürzt und die 3 Zellen eingefügt. sollte aber gehen.
Aber wahrscheinlich ist das jetzt auch wieder falsch - Du willst als Anhang eine Tabelle, wo nur die eine Zeile drin steht? Der ganze Text muss auch rein?
Mehr wird heute Abend leider nicht mehr, bin aber morgen Abend wieder hier.
Code:
Option Explicit
Sub SendSheet()
'Variablendeklarationen
'Objekte
Dim objWb As Workbook
Dim olApp As Object
Dim objMail As Object
'neues Outlook Objekt zuweisen
Set olApp = CreateObject("Outlook.Application")
'Arbeitsmappe Objekt zuweisen
Set objWb = ActiveWorkbook
'Email erstellen
Set objMail = olApp.CreateItem(0)
'Mit der Mappe
With objWb
'On Error Resume Next
'mit dem email
With objMail
'an, auf Tabelle Liste Namen Zelle R3
.To = Sheets("Liste Namen").Cells(3, 18).Value
'.CC = ""
'.BCC = ""
'Betreff
.Subject = "Warum und wieso"
'Textkoerper
.Body = Sheets("Liste Namen").Cells(3, 1).Value & vbtab & Sheets("Liste Namen").Cells(3, 2).Value & vbtab & Sheets("Liste Namen").Cells(3, 18).Value
'email anzeigen
.Display
'Ende mit dem email
End With
'On Error GoTo 0
'Ende Mit der Mappe
End With
'Mailobjekt zuruecksetzen
Set objMail = Nothing
'Outlookobjekt zuruecksetzen
Set olApp = Nothing
End Sub
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)
Das "Mehr" habe ich jetzt mal versucht umzusetzen:
Code:
Option Explicit
Sub Excel_Serial_Mail()
Dim MyMessage As Object, MyOutApp As Object
Dim SavePath As String
Dim AWS As String
Dim i As Long, lngZ As Long
With Sheets("Tabelle1")
lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngZ > 1 Then
.Range(.Cells(2, 1), .Cells(lngZ, 17)).ClearContents
End If
End With
With Sheets("Liste Namen")
lngZ = .Cells(.Rows.Count, 18).End(xlUp).Row
End With
Sheets("Tabelle1").Select
For i = 3 To lngZ
With Sheets("Liste Namen")
Range(Cells(2, 1), Cells(2, 17)).Value = .Range(.Cells(i, 2), .Cells(i, 18)).Value
End With
SavePath = "C:\Users\Thomas\Desktop" 'SPEICHERPFAD ANPASSEN
'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 & "_" & Format(Now, "ddmmyyyy_hhmm") & ".xls"
'Mappenname wird an Variable übergeben
'und anschliessend gleich geschlossen
With ActiveWorkbook
AWS = .FullName
.Close
End With
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
'Der Empfänger stehet in Spalte Q in Zeile 2
.To = Cells(2, 17).Value 'E-Mail Adresse
'Der Betreff in Spalte B
.Subject = "Darum geht es" '"Betreffzeile"
.Attachments.Add AWS
'Der zu sendende Text in Spalte C
'Maximal 1024 Zeichen
'Der Text wird ohne Formatierung übernommen
.Body = "Der Text der für alle angezeigt werden soll" & vbCrLf & _
"mit einer neuen Zeile"
'Hier wird die Mail angezeigt
'.Display
'Hier wird die Mail gleich in den Postausgang gelegt
.Send
End With
Application.DisplayAlerts = False
'Objectvariablen leeren
MyOutApp.Quit
Set MyOutApp = Nothing
Set MyMessage = Nothing
'Sendepause einschalten
'Outlook kann die Aufträge nicht schnell genug verarbeiten
Application.Wait (Now + TimeValue("0:00:05"))
Kill AWS
Application.DisplayAlerts = True
Next i
End Sub
Folgendes wird vorausgesetzt:
-Es befindet sich eine zweite Tabelle in der Datei mit Namen "Tabelle1"
-In Zeile 1 stehen die Überschriften
Es werden die Spalten B bis R rüber geholt und versandt.
Ich würde es so lösen:
Eine weitere Tabelle einfügen, im Code heißt sie "Tabelle2"
In dieser Tabelle in die Zelle A1 den Boddy Text einfügen.
Dann unten stehenden Code nehmen:
Code:
Option Explicit
Sub Excel_Serial_Mail()
Dim MyMessage As Object, MyOutApp As Object
Dim SavePath As String
Dim strgBody As String
Dim AWS As String
Dim i As Long, lngZ As Long
strgBody = Sheets("Tabelle2").Range("A1").Value
With Sheets("Tabelle1")
lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
If lngZ > 1 Then
.Range(.Cells(2, 1), .Cells(lngZ, 17)).ClearContents
End If
End With
With Sheets("Liste Namen")
lngZ = .Cells(.Rows.Count, 18).End(xlUp).Row
End With
Sheets("Tabelle1").Select
For i = 3 To lngZ
With Sheets("Liste Namen")
Range(Cells(2, 1), Cells(2, 17)).Value = .Range(.Cells(i, 2), .Cells(i, 18)).Value
End With
SavePath = "C:\Users\Atilla\Desktop" '"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 & "_" & Format(Now, "ddmmyyyy_hhmm") & ".xls"
'Mappenname wird an Variable übergeben
'und anschliessend gleich geschlossen
With ActiveWorkbook
AWS = .FullName
.Close
End With
Set MyOutApp = CreateObject("Outlook.Application")
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
'Der Empfänger stehet in Spalte Q in Zeile 2
.To = Cells(2, 17).Value 'E-Mail Adresse
'Der Betreff in Spalte B
.Subject = "Darum geht es" '"Betreffzeile"
.Attachments.Add AWS
'Der zu sendende Text in Spalte C
'Maximal 1024 Zeichen
'Der Text wird ohne Formatierung übernommen
.Body = strgBody
'Hier wird die Mail angezeigt
'.Display
'Hier wird die Mail gleich in den Postausgang gelegt
.Send
End With
Application.DisplayAlerts = False
'Objectvariablen leeren
MyOutApp.Quit
Set MyOutApp = Nothing
Set MyMessage = Nothing
'Sendepause einschalten
'Outlook kann die Aufträge nicht schnell genug verarbeiten
Application.Wait (Now + TimeValue("0:00:05"))
Kill AWS
Application.DisplayAlerts = True
Next i
End Sub
Die in der vorigen Antwort aufgezählten Bedingungen gelten weiter
ich habe hier mal meinen Weg weiterverfolgt und den zuerst geposteten code angepasst. Du musst die einzelnen emails dann nur noch senden. Den Betreff müsstest Du noch anpassen.
Das temporäre Blatt wird am Anfang erzeugt und am Ende wieder weggenommen. Unschön ist momentan noch, dass ich die Spaltenbreite nicht mitgenommen habe. Du könntest aber auch ein entsprechendes Blatt, wie von Atilla vorgeaschlagen, erzeugen und formatieren usw. und dann holen wir die Daten nur noch rüber.
Code:
Option Explicit
Sub SendSheet()
'Variablendeklarationen
'Objekte
Dim objWb As Workbook
Dim objWsh As Worksheet
Dim olApp As Object
Dim objMail As Object
'String
Dim strTempFName As String
'Integer
Dim iCnt As Integer
'Variant
Dim arrBody
'neues Outlook Objekt zuweisen
Set olApp = CreateObject("Outlook.Application")
'mit dem aktiven Blatt (aktiv bei Ausfuehrung des With)
With ActiveSheet
'temporaeres Blatt erstellen
Set objWsh = Worksheets.Add
'Schleife ueber alle Addressaten
For iCnt = 3 To .Cells(Rows.Count, 18).End(xlUp).Row
.Rows(2).Copy Cells(2, 1)
.Rows(iCnt).Copy Cells(3, 1)
'Blatt kopieren als neue Mappe
ActiveSheet.Copy
'Arbeitsmappe Objekt zuweisen
Set objWb = ActiveWorkbook
'Name fuer temporaere Datei aus Blattname und Zusaetzen
strTempFName = ActiveSheet.Name & "_ToSend_" & Format(Now, "dd-mmm-yy_h-mm-ss")
'Email erstellen
Set objMail = olApp.CreateItem(0)
'Mit der Mappe
With objWb
.SaveAs "C:\Test\" & strTempFName & ".xlsx", FileFormat:=51
'On Error Resume Next
'mit dem email
With objMail
'an, auf Tabelle Liste Namen Zelle R3
.To = Cells(3, 18).Value
'.CC = ""
'.BCC = ""
'Betreff
.Subject = "Warum und wieso"
arrBody = WorksheetFunction.Transpose(ThisWorkbook.Sheets("Body_Text").Range("A1:A23"))
'Textkoerper
.Body = Join(arrBody, vbLf)
'Anhang hinzufuegen
.Attachments.Add objWb.FullName
'email anzeigen
.Display
'Ende mit dem email
End With
'On Error GoTo 0
'Schliessen der Mappe ohne Speichern
.Close SaveChanges:=False
'Ende Mit der Mappe
End With
'Mailobjekt zuruecksetzen
Set objMail = Nothing
Kill "C:\Test\" & strTempFName & ".xlsx"
'Ende Schleife ueber alle Addressaten
Next
'Ende mit dem aktiven Blatt (aktiv bei Ausfuehrung des With)
End With
'temporaeres Blatt loeschen
objWsh.Delete
'Outlookobjekt zuruecksetzen
Set olApp = Nothing
End Sub
. \\\|/// Hoffe, geholfen zu haben. ( ô ô ) Grüße, André aus G in T ooO-(_)-Ooo (Excel 97-2019+365)