Zellen auslsen und per Outlock verschicken

[knallebumm]

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.

Gruß
Thomas

[Steffl]

Hallo Thomas,

ich kann hier leider deine Datei nicht herunterladen aber vielleicht kannst Du es nach diesem Link lösen.

[Rabe]

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

[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

[WillWissen]

Hi André,

Deine Datei geht übrigens herunter zu laden, da ist aber noch kein Makro drin.

das ist richtig. Aber Stefan(!) kann sie nicht runterladen. Hat nichts mit dem Forum zu tun.

[knallebumm]

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.

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.

Gruß
Thomas

[schauan]

Hallo Thomas,

da hab ich erst mal die Aufgabe umgesetzt:

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

[atilla]

Hallo zusammen,

Andre schrieb:

Mehr wird heute Abend leider nicht mehr...

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.

Im Code den temporären Speicherpfad anpassen:

[atilla]

Hallo noch mal,

hatte es mit dem Boddy übersehen.

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

[schauan]

Hallo Thomas,

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