Emails automatisch mit Excel versenden anhand einer Datenliste
Die folgende Email Datei versendet Emails an einen Datenliste, welche sie einfach in das vorbereitete Datenblatt als Werte einfügen müssen.
Der Emailtext steht als Vorlage im Blatt: _Text und hier können Spalten als Platzhalter [X] wie bei Serien-Emails in jeder Email personalisiert werden.
Die Excel Vorlage ist im Download als Excel Datei mit Makro vorhanden.
Excelblatt: Email
In dem Blatt Email muss man nur den Titel aller Emails eingeben.
Dann die Email Absende-Adresse und den Absender-Namen
Und ganz wichtig: Die Spalte im Datenblatt, in welcher die Email_To Adressen stehen.
Dann nur noch senden klicken und die Emails werden alle automatisch versendet
Blatt: _Text
Hier kommt der Email Text rein.
Einfach die zu ersetzenden Spalten durch den Spaltennamen in Klammern setzen wie [A] für Spalte A
Email Datenliste
Blatt: DataList
In dem Excel Blatt Datalist muss man nur noch die eigenen Daten als Werte einfügen.
Dann muss sich in jeder Zeile der benannten Email-To Spalte eine Email befinden, an welche die Daten-Email gesendet werden soll.
Excel Macro Code (vba)
Option Explicit On
'===================< Region: Email >===================
Public Sub Send_Email() '-------------< Send_Email() >------------- '*Runs trough List and creates single Emails '-< init >- '*Input fields page 1 Dim sTitle As String sTitle = ActiveWorkbook.Names("varTitle").RefersToRange.Value2
Dim sEmail_From As String sEmail_From = ActiveWorkbook.Names("varEmail_From").RefersToRange.Value2
Dim sName_From As String sName_From = ActiveWorkbook.Names("varName_From").RefersToRange.Value2
Dim sColumn_Email_To As String sColumn_Email_To = ActiveWorkbook.Names("varColumn_Email_To").RefersToRange.Value2 '-</ init >-
'< Text > Dim sEmail_Text_Template As String sEmail_Text_Template = Sheets("_Text").Shapes(1).TextFrame2.TextRange.Text '</ Text >
'< get Datasheet > Dim sheet_Datalist As Worksheet Set sheet_Datalist = ThisWorkbook.Sheets("DataList") '</ get Datasheet >
'----< Send with Outlook >---- Dim app_Outlook As Outlook.Application Set app_Outlook = New Outlook.Application Dim objEmail As Outlook.MailItem
'<# Optional: Late-Binding > 'Dim app_Outlook 'Set app_Outlook = CreateObject("Outlook.Application") 'Dim objEmail '</# Optional: Late-Binding >
'----< @Loop: all List-Rows >---- Dim iRow_Sending As Integer For iRow_Sending = 1 To sheet_Datalist.UsedRange.Rows.Count '< get Email Address > Dim sAddress_To As String sAddress_To = sheet_Datalist.Range(sColumn_Email_To & iRow_Sending).Value
'< check end > If sAddress_To Like "" Then Exit For '</ check end > '</ get Email Address >
If sAddress_To Like "*@*.*" Then '----< Email_To is OK >---- '-< Replace all Placeholders >- Dim sText As String sText = sEmail_Text_Template
Dim iCol As Integer For iCol = 1 To sheet_Datalist.UsedRange.Columns.Count '< check_done > If InStr(1, sText, "[", vbTextCompare) < 0 Then Exit For '</ check_done >
Dim sColumnName As String sColumnName = Convert_Number_To_Letter(iCol)
'< replace > If sText Like "*[" & sColumnName & "]*" Then Dim sValue As String sValue = sheet_Datalist.Range(sColumnName & iRow_Sending).Value2 sValue = Trim(sValue) sText = Replace(sText, "[" & sColumnName & "]", sValue, , , vbTextCompare) End If '</ replace > Next '-</ Replace All Placeholders >-
'--< Send Email >-- Dim status_Send As String '?date '<< send >> status_Send = Send_Email_to_Address(sAddress_To, sTitle, sText, "") '<</ send >>
'--</ Send Email >--
'----</ Email_To is OK >---- End If
Next '----</ @Loop: all List-Rows >----
'< Abschluss > Set objEmail = Nothing Set app_Outlook = Nothing '</ Abschluss >
MsgBox "Done", vbInformation, "Done"
'----</ Send with Outlook >---- '-------------</ Send_Email() >------------- End Sub
Public Function Send_Email_to_Address(ByVal sAddress_To As String, ByVal sTitle As String, ByVal sText As String, ByVal sAddresses_CC As String) As String '-------------< Send_Email_to_Address() >------------- '*sends a single email '*uses: outlook '< init > On Error Resume Next '< check > If sAddress_To Like "" Then Send_Email_to_Address = "no: [Email_To] is empty" Exit Function End If '</ check >
'< outlook > Dim app_Outlook As Object Set app_Outlook = CreateObject("Outlook.Application") '</ outlook >
Dim sFiles As String sFiles = ActiveWorkbook.Names("varFiles").RefersToRange.Value2
'--< Send Email >-- Dim objEmail As Object Set objEmail = app_Outlook.CreateItem(0) objEmail.To = sAddress_To If Not sAddresses_CC Like "" Then objEmail.CC = sAddresses_CC '*via address;addess is ok ' Dim arrAddresses() As String ' arrAddresses = Split(sAddresses_CC, ";") ' Dim Address_CC ' For Each Address_CC In arrAddresses ' objEmail.CC.Add Address_CC ' Next End If
objEmail.Subject = sTitle objEmail.Body = sText '*.body for Text, Richtext 'objEmail.HTMLBody = sHTML '*.HTMLBody for HTML
'-< Attach Files >- Dim arrFiles arrFiles = Split(sFiles, ";") Dim sFile For Each sFile In arrFiles If Not sFile Like "" Then If Not sFile Like "*:*" Then sFile = ActiveWorkbook.Path & "\" & sFile End If objEmail.Attachments.Add sFile End If Next '-</ Attach Files >-
'< send > Dim sAutosend As String sAutosend = ActiveWorkbook.Names("varEmail_Autosend").RefersToRange.Text If sAutosend Like "*Sofort*" Then objEmail.Display False objEmail.Send Else objEmail.Display False 'objEmail.Display bVisible '*no visible=true because of : wait on outlook End If '</ send > '--</ create Email >--
'< Abschluss > Set objEmail = Nothing Set app_Outlook = Nothing '</ Abschluss >
If Err.Number <> 0 Then '< error > 'MsgBox "Error on Email=" & sAddress_To & vbCrLf & Err.Description & vbCrLf & "Check Syntax of Email-Address ", vbCritical, "Error on sending.." Send_Email_to_Address = "no: " & Err.Description '</ error > Else '< ok > '*return dtSend Send_Email_to_Address = "ok: " & Now '</ ok > End If
'-------------</ Send_Email_to_Address() >------------- End Function '===================</ Region: Email >===================
'===================< Region: Helper-Functions >=================== Public Function Convert_Number_To_Letter(ByVal Column_Number As Integer) 'Umwandeln einer Excel-Spalten-Nummer in einen Buchstaben, der Spalte Convert_Number_To_Letter = Split(Cells(1, Column_Number).Address, "$")(1) End Function
|