How to send mass emails directly from Excel using VBA without Merge

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.