Readdy Write

Emails automatisch mit Excel versenden anhand einer Datenliste

26.01.2019 (👁14434)

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 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

 

 

 


0,00 €