Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Count
Followers 0
Login Register as User

E-mails automatically with Excel vSend based on a data list

26.01.2019 (👁13708)


 

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 StringByVal sTitle As StringByVal sText As StringByVal sAddresses_CC As StringAs 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