The following email file sends emails to a data list, which they simply have to insert into the prepared data sheet as values.
The email text is a template in the sheet: _ Text and here columns can be personalized as placeholders [X] as with series emails in every email.
The Excel template is available in the download as an Excel file with macro.
Excelblatt: Email
In the sheet email you only have to enter the title of all emails.
Then the email sending address and sender name
And most importantly: The column in the data sheet in which the Email _ To addresses are located.
Then just send click and the emails are all sent automatically
Leaf: _ Text
This is where the email text comes in.
Simply place the columns to replace by the column name in brackets like [A] for column A
Email Datenliste
Blatt: DataList
In the Excel Leaf Datalist, all you have to do is insert your data as values.
Then there must be an email in every line of the named Email-To column to which the data email should be sent.
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
|