Hallo Peter,
kopieren den Code in ein allgemeines Modul deiner Start-Tabelle. Ich gehe davon aus, dass die Datenbank-Datei und der Newsletter im selben Verzeichnis liegen. Auch die Log-Datei wird in diesem Verzeichnis gespeichert. Beachte bitte, dass die Log-Datei ggf. ohne Nachfrage überschrieben wird, falls an einem Tag das Makro mehrmals ausgeführt wird.
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 lngZeile As Long
'Pfad für Newsletter und Protokolldatei festlegen - anpassen
strPfad = "C:\DB - Daten\Newsletter\"
'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
'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
.SaveAs Filename:=strPfad & strName
.Close
End With
'Nachfragen wieder anzeigen
Application.DisplayAlerts = True
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
Gruß
M.O.
