A version of this script has been used to create personalized emails for a list of clients. In my opinion this is much cooler than the in-built merge function because it allows to automate complex calculations and generate any kind of personalized email (even with HTML markup), attach files (which you can also generate on the go right before you send) and whatever else comes to your mind.
I have tried this for 100 emails max and it worked fine for me. I advise not to abuse this and not to try to send much more than that at once because your email probably might end up being blacklisted in spam filters.
First we collect inputs from worksheets. After that we can generate all the needed elements for the email (including tables, buttons and whatever else HTML allows us to do). Here is the backbone of the code:
Option Explicit Sub Mail_small_Text_Outlook() Dim OutApp As Object Dim OutMail As Object Dim strbody As String Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) Dim emailToSendFrom, Subj, nShName As String Dim i, k, AccID, N, qerrors As Integer Dim oAccount As Object Dim ws As Worksheet Dim TimeOut As String TimeOut = ThisWorkbook.Sheets("Settings").Cells(14, 2).Value emailToSendFrom = ThisWorkbook.Sheets("Settings").Cells(2, 2).Value 'get quantity of emails to be sent N = ThisWorkbook.Sheets("Data").Cells(Rows.Count, 3).End(xlUp).Row - 1 'column with emails!!!!! '-----------PREPARE ARRAYS OF DATA TO LOOP THROUGH later while generating emails ----------- ReDim Email(N) As String ReDim Lang(N) As String For i = 1 To N Email(i) = Trim(ThisWorkbook.Sheets("Data").Cells(i + 1, 3).Value) Lang(i) = Trim(ThisWorkbook.Sheets("Data").Cells(i + 1, 4).Value) Next i 'check if language has been specified for each user. If not - exit sub without sending emails and ask to fix For i = 1 To N If Lang(i) <> "EN" And Lang(i) <> "DE" Then MsgBox ("ERROR. No emails have been sent. No language/wrong language selected. Please choose the language for EACH user. Available options: EN and DE") Exit Sub End If Next i 'Loop through emails in the array, generate their content for each of them (if needed) and sending For i = 1 To N Application.StatusBar = "Sending " & Email(i) & " - " & i & " out of " & N Select Case Lang(i) Case "EN" strbody = "Message text. Also possible to use HTML markup here" Subj = "Subject in lang 1" Case "DE" strbody = "Message text. Also possible to use HTML markup here" Subj = "Subject in lang 2" End Select On Error Resume Next 'loop through outlook accounts and find the ID if a specified account 'if we comment this out or the account not found then the email will be sent from the default outlook account For k = 1 To OutApp.Session.accounts.Count If OutApp.Session.accounts.Item(k).smtpAddress = emailToSendFrom Then AccID = k Next k Set oAccount = OutApp.Session.accounts.Item(AccID) '--------------SENDING EMAIL With OutApp.CreateItem(0) Set .SendUsingAccount = oAccount .Sender = emailToSendFrom .To = Email(i) .CC = "" .BCC = "" .Subject = Subj .HTMLBody = strbody '.Attachments.Add ("C:\test.txt") '.Display .Send End With If TimeOut = "1" Then Application.Wait (Now + TimeValue("0:00:01")) End If Next i End Sub
Please let me know if you would like to see downloadable examples of this.