615 Aufrufe
Gefragt in Tabellenkalkulation von peters Mitglied (522 Punkte)
Hallo zusammen,

ich habe eine Kundendatei in Excel angelegt. Sehr rudimentär und einfach.

Nun möchte ich meinen Kunden E-Mails zusenden und das Tabellenblatt mit den Kundendaten dafür nutzen.
Ich stelle mir vor, dass ich je Kunden 2 Felder nutze.
Sagen wir einmal in Spalte A die E-Mail-Adresse und Spalte B den Wert "j" für JA und "n" für NEIN
(nicht jeder möchte Newsletter bekommen).

Nun würde ich gerne eine Routine starten, die jede einzelne Zeile ausliest, bei "n" in Spalte B oder leerem Feld A weiterspringt und ansonsten dem Adressaten eine E-Mail mit einem PDF im Anhang sendet.

Einen Text für den Body der E-Mail möchte ich in einer Textdateil hinterlegen.

Und entweder soll der Text neutral gehalten werden ohne persönliche Anrede, oder die ebenfalls in der Tabelle hinterlegten Ansprechpartner genutzt werden.

Hat da jemand eine Idee zu?

Gruß

Peter

30 Antworten

0 Punkte
Beantwortet von

Hallo M.O.,

ich habe den Fehler gefunden. Dort, wo die Protokolldatei geschrieben wird, fehlte
& "Newsletter\"
im .SaveAs ....

Dadurch wurde die Protokolldatei stets unter
"C:\DB - Daten\" anstatt unter "C:\DB - Daten\Newsletter\"
gespeichert.

Alles gut. :-)

Eine andere Frage beschäftigt mich gerade.
Ich würde gern E-Mail-Adressen für den Versand quasi hardcodieren, also zusätzlich 1-2 Kontroll-E-Mail-Adressen direkt im Code hinterlegen.

Wie bekomme ich die denn zusätzlich in das Array?

Grüße

Peter

0 Punkte
Beantwortet von peters Mitglied (522 Punkte)

Hallo M.O.,

gerade habe ich eine Antwort geschrieben ohne angemeldet zu sein. Die müsste auch irgendwann hier auftauchen.
Zusammengefasst steht dort, dass beim Speichern der Kontrolldatei die Pfadergänzung

& "Newsletter\"  fehlte, so dass die Kontrolldatei im Verzeichnis "C:\DB - Daten\" landete.
Das habe ich jetzt verstanden und korrigiert. Alles gut.  :-)

Im Moment beschäftigen mich noch 2 Dinge.
- ich möchte hardcodierte E-Mail-Adressen mit ins Array schreiben, quasi als Kontroll-Adressen. Wie bekomme ich das denn hin?
- ich möchte das Überschreiben der Kontrolldatei verhindern, falls mehrere NL gleichentags versendet werden. (Sollte ein MA den NL  aus irgendeinem Grund mehrfach abschicken, möchte ich das sehen können. Immerhin würden dann Kunden zugespamt, was in der aktuellen Version nicht auffallen würde).
Da würde ich gern, sofern die Kontrolldatei bereits vorhanden ist, diese um eine fortlaufende Nummer ergänzen, also 
"2024-08-30.xlsx", "2024-08-30 - 1.xlsx", "2024-08-30 - 2.xlsx" usw.

Grüße
Peter
0 Punkte
Beantwortet von m-o Profi (22.9k Punkte)

Hallo Peter,

hier das angepasste Makro:

Sub newsletter()
'Achtung: Für dieses Makro müssen im VBA-Editor unter Extras - Verweise bei Microsoft Outlook XX.0 Object Library entsprechende Haken gesetzt werden

Dim vDB As Variant
Dim lngLZ As Long
Dim lngLS As Long
Dim i As Integer
Dim wbKunden As Workbook
Dim olApp As Object
Dim strBody As String
Dim strAnlage As String
Dim Antwort
Dim bNewsletter As Boolean
Dim wbNewsletter As Workbook
Dim strName As String
Dim strPfad As String
Dim strNeu As String
Dim strNeuName As String
Dim lngZeile As Long

'Pfad für Newsletter und Protokolldatei festlegen - anpassen
'strNewsletter = "C:\DB - Daten\Newsletter\" & strNewsletter & ".pdf"
strPfad = "C:\Test\"

'Name für Newsletter generieren
'ggf. führende Nullen für Monat und Tag hinzufügen
If Month(Now) < 10 Then
  strNewsletter = Year(Now) & "-0" & Month(Now)
 Else
  strNewsletter = Year(Now) & "-" & Month(Now)
End If

If Day(Now) < 10 Then
  strNewsletter = strNewsletter & "-0" & Day(Now)
 Else
  strNewsletter = strNewsletter & "-" & Day(Now)
End If

'Name für Excel-Datei in Variable schreiben
strName = strNewsletter

'Pfad für Newsletter ergänzen und Endung für PDF ergänzen - Pfad anpassen
strNewsletter = strPfad & strNewsletter & ".pdf"

bNewsletter = True      'ein Newsletter wird mit verschickt

'Prüfen, ob Newsletter vorhanden ist
If Dir(strNewsletter) = "" Then
  'falls nicht vorhanden, nachfragen, ob trotztdem E-Mail verschickt soll
   Antwort = MsgBox("Achtung! Der Newsletter " & strNewsletter & " ist nicht vorhanden? Sollen die E_Mails trotzdem verschickt werden?", 20, "Kein Newsletter vorhanden")
   If Antwort = vbNo Then
      Exit Sub  'Makro beenden, falls Nein gedrückt wurde
     Else
      bNewsletter = False   'kein Newsletter im Anhang
   End If
End If

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Mögliche Nachfragen und Hinweise ausschalten
Application.DisplayAlerts = False

'Datei mit Kundendatenbank öffnen
'Pfad und Name anpassen;
Set wbQuelle = Workbooks.Open(strPfad & "DB - Kunden.xlsm")
'letzte Zeile und Spalte ermitteln
With wbQuelle.Worksheets("Adressen")
  lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row       'letzte Zeile in Spalte A ermitteln
  lngLS = .UsedRange.SpecialCells(xlCellTypeLastCell).Column 'Letzte Spalte ermitteln
  'zwei feste E-Mail-Adressen und Newsletterversand erwünscht am Ende der Tabelle ergänzen
  'E-Mail-Adressen anpassen
  .Cells(lngLZ + 1, 10) = "testmail01@testmail"
  .Cells(lngLZ + 1, 22) = "j"
  .Cells(lngLZ + 2, 10) = "testmail01@testmail"
  .Cells(lngLZ + 2, 22) = "j"
  lngLZ = .Cells(Rows.Count, 10).End(xlUp).Row       'letzte Zeile in Spalte j neu ermitteln
  
  'Daten in Array einlesen
  vDB = .Range(.Cells(1, 1), .Cells(lngLZ, lngLS))
End With

'Datei wieder schließen ohne Änderungen zu speichern
wbQuelle.Close (False)

'Variable zurücksetzen
Set wbQuelle = Nothing

'Mail-Text in Variable einlesen
strBody = ThisWorkbook.ActiveSheet.Range("H30")

'Outlook definieren
Set olApp = CreateObject("Outlook.Application")

'Datei für Nachverfolgung Versand Newsletter erstellen
Set wbNewsletter = Workbooks.Add
strNeu = wbNewsletter.Name
'Überschriften einfügen
With Workbooks(strNeu).Worksheets(1)
  .Range("A1") = "Name"
  .Range("B1") = "E-Mail"
  .Range("C1") = "Newsletter"
  With .Range("A1:C1")
   .Font.Bold = True                   'Fett
   .HorizontalAlignment = xlCenter     'zentriert
  End With
End With

'1. Einfügezeile festlegen
lngZeile = 2

'Array ab Zeile 2 durchlaufen (Zeile 1 = Überschriften)
For i = 2 To UBound(vDB, 1)
  'prüfen ob Newsletter gewünscht ist, Spalte V
  If LCase(vDB(i, 22)) = "j" Then
     'prüfen, ob etwas in Spalte V (E-Mail-Adresse) steht
     If vDB(i, 10) <> "" Then
       'E-Mail generieren
         With olApp.CreateItem(0)
          strAdresse = vDB(i, 10)
          .To = strAdresse 'Empfänger"
          .Subject = "Newsletter" 'Betreff
          .Body = strBody 'Nachricht
          .ReadReceiptRequested = False 'Lesebestätigung aus
          If bNewsletter = True Then .Attachments.Add strNewsletter    'Anhang
          .Display 'Email anzeigen
          'und hier wird die Nachricht gesendet
          '.Send
        End With
        'Daten in Excel-Tabelle schreiben
         With Workbooks(strNeu).Worksheets(1)
           .Cells(lngZeile, 1) = vDB(i, 1)  'Name in Spalte A Schreiben
           .Cells(lngZeile, 2) = vDB(i, 10) 'E-Mail-Adresse in Spalte B schreiben
           If bNewsletter = False Then
               .Cells(lngZeile, 3) = "ohne Newsletter"   'falls Nachricht ohne Newsletter versandt wurde
           Else
               .Cells(lngZeile, 3) = strName & ".pdf"     'Nachricht wurde mit Newsletter versandt
           End If
         End With
         'Einfügezeile erhöhen
         lngZeile = lngZeile + 1
        End If
  End If
Next i

Set olApp = Nothing       'zurücksetzen

With Workbooks(strNeu)
  With .Worksheets(1)
    .Columns("A:C").EntireColumn.AutoFit     'Spaltenbreite in der neuen Excel-Datei anpassen
  End With
  'Datei speichern
  'Zähler festlegen
  i = 0
  Do
    'Zähler erhöhen
    i = i + 1
    'Zählung anfügen
    If i < 10 Then
      strNeuName = strPfad & strName & "-0" & i
     Else
      strNeuName = strPfad & strName & "-" & i
    End If
  Loop Until Dir(strNeuName & ".xlsx") = ""
    'Datei noch nicht vorhanden, daher speichern
    .SaveAs Filename:=strNeuName
  .Close
End With

'Nachfragen wieder anzeigen
Application.DisplayAlerts = True

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Im Code werden zwei E-Mail-Adressen ergänzt. Wenn du mehr brauchst, kannst du diese einfach wie dargestellt erweitern.

Die Newsletter werden jetzt mit "2024-08-30-01.xlsx", "2024-08-30-02.xlsx" etc. gespeichert.

Gruß

M.O.

0 Punkte
Beantwortet von peters Mitglied (522 Punkte)

Hallo M.O.,

das funktioniert toll, vielen Dank!

Kann man die zusätzlich angefügten Kontroll-Adressen aus dem Array löschen, bevor die Kontrolldatei nach dem Versand geschrieben wird?
(das ist aber eher ein kosmetisches Problem).

Bei mir sieht der Code nun so aus:


Sub newsletter()
'Achtung: Für dieses Makro müssen im VBA-Editor unter Extras - Verweise bei Microsoft Outlook XX.0 Object Library entsprechende Haken gesetzt werden

'Sicherheitsabfrage vorab, ob der Newsletter jetzt verschickt werden soll
   AntwortStart = MsgBox("Achtung!" & Chr(10) & Chr(10) & "Sollen die E-Mails jetzt verschickt werden?", 20, "Newsletter-Versand")
   If AntwortStart = vbNo Then
      Exit Sub  'Makro beenden, falls Nein gedrückt wurde
     Else
      
   End If

Dim vDB As Variant
Dim lngLZ As Long
Dim lngLS As Long
Dim i As Integer
Dim wbKunden As Workbook
Dim olApp As Object
Dim strBody As String
Dim strBody2 As String
Dim strAnlage As String
Dim Antwort
Dim bNewsletter As Boolean
Dim wbNewsletter As Workbook
Dim strName As String
Dim strDatum As String
Dim strPfad As String
Dim strNeu As String
Dim strNeuName As String
Dim lngZeile As Long
Dim strSubject As String

'Pfad für Newsletter und Protokolldatei festlegen - anpassen
strPfad = "Z:\DB - Daten\"

'Datum für Newsletter- generieren
'ggf. führende Nullen für Monat und Tag hinzufügen
GoTo vorbei
If Day(Now) < 10 Then
  strDatum = "0" & Day(Now)
Else
  strDatum = Day(Now)
End If

If Month(Now) < 10 Then
  strDatum = strDatum & ".0" & Month(Now) & "." & Year(Now)
Else
  strDatum = strDatum & "." & Month(Now) & "." & Year(Now)
vorbei:
strDatum = ThisWorkbook.ActiveSheet.Range("F4")
End If


'Name für Newsletter generieren
'ggf. führende Nullen für Monat und Tag hinzufügen
If Month(Now) < 10 Then
  strnewsletter = Year(Now) & "-0" & Month(Now)
Else
  strnewsletter = Year(Now) & "-" & Month(Now)
End If

If Day(Now) < 10 Then
  strnewsletter = strnewsletter & "-0" & Day(Now)
Else
  strnewsletter = strnewsletter & "-" & Day(Now)
End If

'Name für Excel-Datei in Variable schreiben
strName = strnewsletter

'Pfad für Newsletter ergänzen und Endung für PDF ergänzen - Pfad anpassen
strnewsletter = strPfad & "Newsletter\" & strnewsletter & ".pdf"

bNewsletter = True      'ein Newsletter wird mit verschickt

'Prüfen, ob Newsletter vorhanden ist
If Dir(strnewsletter) = "" Then
  'falls nicht vorhanden, nachfragen, ob trotztdem E-Mail verschickt soll
   Antwort = MsgBox("Achtung!" & Chr(10) & Chr(10) & "Der Newsletter-Anhang" & Chr(10) & Chr(10) & strnewsletter & Chr(10) & Chr(10) & "ist nicht vorhanden!" & Chr(10) & Chr(10) & "Sollen die E-Mails trotzdem verschickt werden?", 20, "Kein Newsletter vorhanden!")
   If Antwort = vbNo Then
      Exit Sub  'Makro beenden, falls Nein gedrückt wurde
     Else
      bNewsletter = False   'kein Newsletter im Anhang
   End If
End If

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Mögliche Nachfragen und Hinweise ausschalten
Application.DisplayAlerts = False

'Datei mit Kundendatenbank öffnen
'Pfad und Name anpassen;
Set wbQuelle = Workbooks.Open(strPfad & "DB - Kunden.xlsm")
'letzte Zeile und Spalte ermitteln
With wbQuelle.Worksheets("Adressen")
  lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row       'letzte Zeile in Spalte A ermitteln
  lngLS = .UsedRange.SpecialCells(xlCellTypeLastCell).Column 'Letzte Spalte ermitteln
 
  'zwei feste E-Mail-Adressen und Newsletterversand erwünscht am Ende der Tabelle ergänzen
  'E-Mail-Adressen anpassen
  .Cells(lngLZ + 1, 10) = "Kontroll@E-Mail"
  .Cells(lngLZ + 1, 22) = "j"
  .Cells(lngLZ + 2, 10) = "Kontroll@E-Mail"
  .Cells(lngLZ + 2, 22) = "j"
  lngLZ = .Cells(Rows.Count, 10).End(xlUp).Row       'letzte Zeile in Spalte j neu ermitteln
 
 
  'Daten in Array einlesen
  vDB = .Range(.Cells(1, 1), .Cells(lngLZ, lngLS))
End With

'Datei wieder schließen ohne Änderungen zu speichern
wbQuelle.Close (False)

'Variable zurücksetzen
Set wbQuelle = Nothing

'Mail-Text in Variable einlesen
strBody = ThisWorkbook.ActiveSheet.Range("F8")

'Mail-Text in Variable einlesen ***** Neue Version ****
'Der Body der E-Mail wird aus einzelnen Bausteinen (Anrede, Nachricht, Grußformel, Verfasser, Schlussformel) zusammengesetzt
'Betreff wird definiert
strBody2 = ThisWorkbook.ActiveSheet.Range("F6") & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F8") & Chr(10) & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F24")
strBody2 = strBody2 & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F26") & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F29")
strSubject = ThisWorkbook.ActiveSheet.Range("F2")


'Outlook definieren
Set olApp = CreateObject("Outlook.Application")

'Datei für Nachverfolgung Versand Newsletter erstellen
Set wbNewsletter = Workbooks.Add
strNeu = wbNewsletter.Name
'Überschriften einfügen
With Workbooks(strNeu).Worksheets(1)
  .Range("A1") = "Name"
  .Range("B1") = "E-Mail"
  .Range("C1") = "Newsletter"
  With .Range("A1:C1")
   .Font.Bold = True                   'Fett
   .HorizontalAlignment = xlCenter     'zentriert
  End With
End With

'1. Einfügezeile festlegen
lngZeile = 2

'Array ab Zeile 2 durchlaufen (Zeile 1 = Überschriften)
For i = 2 To UBound(vDB, 1)
  'prüfen ob Newsletter gewünscht ist, Spalte V
  If LCase(vDB(i, 22)) = "j" Then
     'prüfen, ob etwas in Spalte V (E-Mail-Adresse) steht
     If vDB(i, 10) <> "" Then
       'E-Mail generieren
         With olApp.CreateItem(0)
          strAdresse = vDB(i, 10)
          .To = strAdresse 'Empfänger"
          .Subject = strSubject & " - " & strDatum 'Betreff
          .Body = strBody2 'Nachricht
          .ReadReceiptRequested = False 'Lesebestätigung aus
          If bNewsletter = True Then .Attachments.Add strnewsletter    'Anhang
          '.Display 'Email anzeigen
          'und hier wird die Nachricht gesendet
          .Send
        End With

'Daten in Excel-Tabelle schreiben
         With Workbooks(strNeu).Worksheets(1)
           .Cells(lngZeile, 1) = vDB(i, 1)  'Name in Spalte A Schreiben
           .Cells(lngZeile, 2) = vDB(i, 10) 'E-Mail-Adresse in Spalte B schreiben
           If bNewsletter = False Then
               .Cells(lngZeile, 3) = "ohne Anhang"   'falls Nachricht ohne Newsletter versandt wurde
           Else
               .Cells(lngZeile, 3) = strName & ".pdf"     'Nachricht wurde mit Newsletter versandt
           End If
         End With
         'Einfügezeile erhöhen
         lngZeile = lngZeile + 1
        End If
  End If
Next i

Set olApp = Nothing       'zurücksetzen

With Workbooks(strNeu)
  With .Worksheets(1)
    .Columns("A:C").EntireColumn.AutoFit     'Spaltenbreite in der neuen Excel-Datei anpassen
  End With
  'Datei speichern
 
  'Zähler festlegen
  i = 0
  Do
    'Zähler erhöhen
    i = i + 1
    'Zählung anfügen
    If i < 10 Then
      strNeuName = strPfad & "Newsletter\" & strName & "-0" & i
     Else
      strNeuName = strPfad & "Newsletter\" & strName & "-" & i
    End If
  Loop Until Dir(strNeuName & ".xlsx") = ""
    'Datei noch nicht vorhanden, daher speichern
    .SaveAs Filename:=strNeuName
 
 
 
  .Close
End With

'Nachfragen wieder anzeigen
Application.DisplayAlerts = True

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Mein nächster Schritt wäre nun, die Anrede zu personalisieren, sofern in den Spalten H und I entsprechende Eintragungen vorhanden sind.
(in Spalte H findet sich "Herr" oder "Frau" und in Spalte I der Nachname). So ergäben sich 3 unterschiedliche Ansprachen (Sehr geehrte Frau, Sehr geehreter Herr, oder eben allgemein), die beim Einlesen des Mail-Textes berücksichtigt werden könnten.

Ich habe allerdings die Befürchtung, dass das ein gänzlich anderer Code wäre, bei dem der E-Mail-Test für jede E-Mail eiinzeln zusammengesetzt werden müsste, oder?

Grüße

Peter

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

Hallo Peter,

ich habe mal dein Makro nach deinen Wünschen angepasst. Nur bei der Erstellung der E-Mail-Nachricht musst du selbst mal schauen, da die Anrede ja jetzt personalisiert ist:

Sub newsletter()
'Achtung: Für dieses Makro müssen im VBA-Editor unter Extras - Verweise bei Microsoft Outlook XX.0 Object Library entsprechende Haken gesetzt werden

'Sicherheitsabfrage vorab, ob der Newsletter jetzt verschickt werden soll
   AntwortStart = MsgBox("Achtung!" & Chr(10) & Chr(10) & "Sollen die E-Mails jetzt verschickt werden?", 20, "Newsletter-Versand")
   If AntwortStart = vbNo Then
      Exit Sub  'Makro beenden, falls Nein gedrückt wurde
     Else
      
   End If

Dim vDB As Variant
Dim lngLZ As Long
Dim lngLS As Long
Dim i As Integer
Dim wbKunden As Workbook
Dim olApp As Object
Dim strBody As String
Dim strBody2 As String
Dim strAnlage As String
Dim Antwort
Dim bNewsletter As Boolean
Dim wbNewsletter As Workbook
Dim strName As String
Dim strDatum As String
Dim strPfad As String
Dim strNeu As String
Dim strNeuName As String
Dim lngZeile As Long
Dim strSubject As String
Dim strAnrede As String

'Pfad für Newsletter und Protokolldatei festlegen - anpassen
strPfad = "Z:\DB - Daten\"

'Datum für Newsletter- generieren
'ggf. führende Nullen für Monat und Tag hinzufügen
GoTo vorbei
If Day(Now) < 10 Then
  strDatum = "0" & Day(Now)
Else
  strDatum = Day(Now)
End If

If Month(Now) < 10 Then
  strDatum = strDatum & ".0" & Month(Now) & "." & Year(Now)
Else
  strDatum = strDatum & "." & Month(Now) & "." & Year(Now)
vorbei:
strDatum = ThisWorkbook.ActiveSheet.Range("F4")
End If

'Name für Newsletter generieren
'ggf. führende Nullen für Monat und Tag hinzufügen
If Month(Now) < 10 Then
  strnewsletter = Year(Now) & "-0" & Month(Now)
Else
  strnewsletter = Year(Now) & "-" & Month(Now)
End If

If Day(Now) < 10 Then
  strnewsletter = strnewsletter & "-0" & Day(Now)
Else
  strnewsletter = strnewsletter & "-" & Day(Now)
End If

'Name für Excel-Datei in Variable schreiben
strName = strnewsletter

'Pfad für Newsletter ergänzen und Endung für PDF ergänzen - Pfad anpassen
strnewsletter = strPfad & "Newsletter\" & strnewsletter & ".pdf"

bNewsletter = True      'ein Newsletter wird mit verschickt

'Prüfen, ob Newsletter vorhanden ist
If Dir(strnewsletter) = "" Then
  'falls nicht vorhanden, nachfragen, ob trotztdem E-Mail verschickt soll
   Antwort = MsgBox("Achtung!" & Chr(10) & Chr(10) & "Der Newsletter-Anhang" & Chr(10) & Chr(10) & strnewsletter & Chr(10) & Chr(10) & "ist nicht vorhanden!" & Chr(10) & Chr(10) & "Sollen die E-Mails trotzdem verschickt werden?", 20, "Kein Newsletter vorhanden!")
   If Antwort = vbNo Then
      Exit Sub  'Makro beenden, falls Nein gedrückt wurde
     Else
      bNewsletter = False   'kein Newsletter im Anhang
   End If
End If

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Mögliche Nachfragen und Hinweise ausschalten
Application.DisplayAlerts = False

'Datei mit Kundendatenbank öffnen
'Pfad und Name anpassen;
Set wbQuelle = Workbooks.Open(strPfad & "DB - Kunden.xlsm")
'letzte Zeile und Spalte ermitteln
With wbQuelle.Worksheets("Adressen")
  lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row       'letzte Zeile in Spalte A ermitteln
  lngLS = .UsedRange.SpecialCells(xlCellTypeLastCell).Column 'Letzte Spalte ermitteln
 
  'zwei feste E-Mail-Adressen und Newsletterversand erwünscht am Ende der Tabelle ergänzen
  'E-Mail-Adressen anpassen
  .Cells(lngLZ + 1, 10) = "Kontroll@E-Mail"
  .Cells(lngLZ + 1, 22) = "j"
  .Cells(lngLZ + 2, 10) = "Kontroll@E-Mail"
  .Cells(lngLZ + 2, 22) = "j"
  lngLZ = .Cells(Rows.Count, 10).End(xlUp).Row       'letzte Zeile in Spalte j neu ermitteln
 
 
  'Daten in Array einlesen
  vDB = .Range(.Cells(1, 1), .Cells(lngLZ, lngLS))
End With

'Datei wieder schließen ohne Änderungen zu speichern
wbQuelle.Close (False)

'Variable zurücksetzen
Set wbQuelle = Nothing

'Mail-Text in Variable einlesen
strBody = ThisWorkbook.ActiveSheet.Range("F8")

'Mail-Text in Variable einlesen ***** Neue Version ****  -- ANPASSEN --
'Der Body der E-Mail wird aus einzelnen Bausteinen (Anrede, Nachricht, Grußformel, Verfasser, Schlussformel) zusammengesetzt
'Betreff wird definiert
strBody2 = ThisWorkbook.ActiveSheet.Range("F6") & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F8") & Chr(10) & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F24")
strBody2 = strBody2 & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F26") & Chr(10) & Chr(10) & ThisWorkbook.ActiveSheet.Range("F29")
strSubject = ThisWorkbook.ActiveSheet.Range("F2")

'Outlook definieren
Set olApp = CreateObject("Outlook.Application")

'Datei für Nachverfolgung Versand Newsletter erstellen
Set wbNewsletter = Workbooks.Add
strNeu = wbNewsletter.Name
'Überschriften einfügen
With Workbooks(strNeu).Worksheets(1)
  .Range("A1") = "Name"
  .Range("B1") = "E-Mail"
  .Range("C1") = "Newsletter"
  With .Range("A1:C1")
   .Font.Bold = True                   'Fett
   .HorizontalAlignment = xlCenter     'zentriert
  End With
End With

'1. Einfügezeile festlegen
lngZeile = 2

'Array ab Zeile 2 durchlaufen (Zeile 1 = Überschriften)
For i = 2 To UBound(vDB, 1)
  'prüfen ob Newsletter gewünscht ist, Spalte V
  If LCase(vDB(i, 22)) = "j" Then
     'prüfen, ob etwas in Spalte V (E-Mail-Adresse) steht
     If vDB(i, 10) <> "" Then
       'Anrede generieren
       Select Case (vDB(i, 8))
         Case Is = "Herr"
           strAnrede = "Sehr geehrter Herr " & vDB(i, 9) & "," & Chr(10) & Chr(10)
         Case Is = "Frau"
           strAnrede = "Sehr geehrte Frau " & vDB(i, 9) & "," & Chr(10) & Chr(10)
         Case Else
           strAnrede = "Sehr geehrte Damen und Herren," & Chr(10) & Chr(10)
       End Select
           
       'E-Mail generieren
         With olApp.CreateItem(0)
          strAdresse = vDB(i, 10)
          .To = strAdresse 'Empfänger"
          .Subject = strSubject & " - " & strDatum 'Betreff
          .Body = strAnrede & strBody2 'Nachricht
          .ReadReceiptRequested = False 'Lesebestätigung aus
          If bNewsletter = True Then .Attachments.Add strnewsletter    'Anhang
          '.Display 'Email anzeigen
          'und hier wird die Nachricht gesendet
          .Send
        End With

'Daten in Excel-Tabelle schreiben
         With Workbooks(strNeu).Worksheets(1)
           .Cells(lngZeile, 1) = vDB(i, 1)  'Name in Spalte A Schreiben
           .Cells(lngZeile, 2) = vDB(i, 10) 'E-Mail-Adresse in Spalte B schreiben
           If bNewsletter = False Then
               .Cells(lngZeile, 3) = "ohne Anhang"   'falls Nachricht ohne Newsletter versandt wurde
           Else
               .Cells(lngZeile, 3) = strName & ".pdf"     'Nachricht wurde mit Newsletter versandt
           End If
         End With
         'Einfügezeile erhöhen
         lngZeile = lngZeile + 1
        End If
  End If
Next i

Set olApp = Nothing       'zurücksetzen

With Workbooks(strNeu)
  With .Worksheets(1)
    'feste E-Mail-Adressen löschen
    'dazu letzte Zeile in Spalte B ermitteln
    lngLZ = .Cells(Rows.Count, 2).End(xlUp).Row
    .Range(Cells(lngLZ - 1, 1), Cells(lngLZ, 1)).EntireRow.Delete xlShiftUp
    .Columns("A:C").EntireColumn.AutoFit     'Spaltenbreite in der neuen Excel-Datei anpassen
  End With
  'Datei speichern
  'Zähler festlegen
  i = 0
  Do
    'Zähler erhöhen
    i = i + 1
    'Zählung anfügen
    If i < 10 Then
      strNeuName = strPfad & strName & "-0" & i
     Else
      strNeuName = strPfad & strName & "-" & i
    End If
  Loop Until Dir(strNeuName & ".xlsx") = ""
    'Datei noch nicht vorhanden, daher speichern
    .SaveAs Filename:=strNeuName
  .Close
End With

'Nachfragen wieder anzeigen
Application.DisplayAlerts = True

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

0 Punkte
Beantwortet von peters Mitglied (522 Punkte)
Hallo M.O.,

der Code kam inzwischen unter Echtbedingungen zum Einsatz.
Der funzt grundsätzlich sehr gut. Nochmals großen Dank an dieser Stelle von mir!

Was aufgefallen ist, ist dass beim Versenden keine im Outlook hinterlegte E-Mail-Signatur genutzt wird.

Gibt es eine Möglichkeit, ein definiertes E-Mail-Konto und damit dessen hinterlegte Signatur zu nutzen?
(also z.B. info@domain.de)

Grüße

Peter
0 Punkte
Beantwortet von m-o Profi (22.9k Punkte)

Hallo Peter,

gibt es eine Standard-E-Mail-Signatur?

Dann kannst du den Code einfach wie folgt ergänzen:

 'E-Mail generieren
         With olApp.CreateItem(0)
          .Getinspector.Display  'Standardsignatur einfügen
          strAdresse = vDB(i, 10)

Gruß

M.O.

0 Punkte
Beantwortet von peters Mitglied (522 Punkte)
Hallo M.O.,

danke für die schnelle Antwort.
Aber wo und wie genau kommt das in den Code?

Gruß

Peter
0 Punkte
Beantwortet von peters Mitglied (522 Punkte)

Hallo M.O.,

ich habe die Stelle dann doch gefunden und die eine Zeile eingefügt. Allerdings bleibt diese ohne Auswirkung.

Gibt es eine Möglichkeit, die Signatur auszuwählen, die gewünscht wird?

Grüße

Peter

0 Punkte
Beantwortet von peters Mitglied (522 Punkte)
Hallo M.O.,

die Codezeile habe ich eingefügt, allerdings passiert da weiter nichts.
Gibt es da noch etwas, das ich einstellen/anhaken muss?

Und kann ich auch bestimmte Outlook-Konten bzw. deren Signaturen direkt ansprechen zur Nutzung?

Grüße

Peter
...