Split table and send per email

S

Skovgaard

Board Regular
Joined
Oct 18, 2013
Messages
204
Office Version
  1. 365
Platform
  1. Windows
Hi experts,

I've been giving a challenge and are looking for inspiration or a direction of which way to go.

Each week a list like below, which will contain 150-200 unique customer numbers, are manually being split by customer, and a separate email are being sent to each customer.
This is a very time consuming job, so was hoping some of the process could be automated.

My first approach/thought was to split the table per customer, into multiple sheets (have a macro that can do that) and then somehow send it automatically per email.

What do you think, is my approach possible or would you go in another direction?
Any advice would be much appreciated or if you know about something similar that has already been made and can be used as inspiration.

1710829947379.png


/Skovgaard
 
Sort by date Sort by votes
Domenic said:
That's interesting, when I tested the code it seemed to work...

View attachment 112681

In any case, to add a signature that you've already set up, try the following....

1) Add the following code to your module...

VBA Code: 
Public Function FileExists(ByVal sFullname As String) As Boolean

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    FileExists = FSO.FileExists(sFullname)
   
    Set FSO = Nothing
   
End Function

Public Function GetBoiler(ByVal sFile As String) As String

    Dim FSO As Object
    Dim ts As Object
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
   
    GetBoiler = ts.readall
   
    ts.Close
   
End Function

2) Then amend your code as follows...

VBA Code: 
    Dim signatureFileName As String
    Dim signatureHTML As String
   
    signatureFileName = Environ("appdata") & "\Microsoft\Signatures\MySignature.htm" 'change the file name (MySignature.htm) accordingly

    If FileExists(signatureFileName) Then
        signatureHTML = GetBoiler(signatureFileName)
    Else
        signatureHTML = ""
    End If

    With olMailItem
        .Display 'must be displayed before being able to paste
        .To = EmailAddress
        .Subject = Subject
        .HTMLBody = "<p>This is the body of the email...</p>"
        Rng.Copy
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
        .HTMLBody = .HTMLBody & signatureHTML
        '.Send
    End With

Hope this helps!
Click to expand...

I have now tested for a while and it works, thanks Domenic! 👍

Some times I get below Run-time error, often the first time I run the code.
I solve it by closing Excel, open again and run it once again.

Can this be fixed?

1719294283765.png


After pressing debug:

1719294299099.png


/Skovgaard
 
Upvote 0

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Try adding DoEvents after copying the range...

VBA Code: 
        Rng.Copy
        DoEvents
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With

Actually, just for good measure, I might also pause the macro for a few seconds. So first add the following macro to your module...

VBA Code: 
Sub PauseMacro(ByVal secs As Long)

    Dim endTime As Single
    endTime = Timer + secs
   
    Do
        DoEvents
    Loop Until Timer > endTime
   
End Sub

Then try...

VBA Code: 
        Rng.Copy
        PauseMacro 3 'seconds (although a 1 second delay may suffice)
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With

Hope this helps!
 
Last edited:
Upvote 0
After changing my code to your last two codes, I got the same run-time error first time I ran it.
I closed Excel, did the exact same again and then it worked. I have tried it on a co-worker and there it worked the first time.

I will do some testing the following week and get back to you.

Thanks for now!

/Skovgaard
 
Upvote 0
I'm assuming that you're still displaying the email before pasting, correct?

VBA Code: 
    With olMailItem
        .display 'must be displayed before being able to paste
        'etc
        '
        '
    End With

Also, can you confirm which error message you're getting, and on which line?
 
Upvote 0
Domenic said:
I'm assuming that you're still displaying the email before pasting, correct?

VBA Code: 
    With olMailItem
        .display 'must be displayed before being able to paste
        'etc
        '
        '
    End With

Also, can you confirm which error message you're getting, and on which line?
Click to expand...

Correct, I still have the .display in my code.

This is the error message I get:
1719567728276.png


And it's on this line:
1719567808433.png


/Skovgaard
 
Upvote 0
Yeah, okay, it must be a timing issue. So I've taken a closer look at the code, and I've amended it. I've added DoEvents at various locations. Does this help?

VBA Code: 
Option Explicit

Sub SendEmailsByCustomer()

    Dim dicCustomers As Object
    Dim olApp As Object
    Dim wsSource As Worksheet
    Dim rngFilter As Range
    Dim lastRow As Long
    Dim rowIndex As Long
    Dim customerNo As String
    Dim customerName As String
    Dim emailAddress As String
    Dim subject As String
 
    Set wsSource = ActiveSheet
 
    With wsSource
        If .FilterMode Then .ShowAllData
    End With
 
    With wsSource
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
 
    Set dicCustomers = CreateObject("Scripting.Dictionary")
 
    Set olApp = CreateObject("Outlook.Application")
 
    subject = "MySubject" 'change as desired
 
    With wsSource
        For rowIndex = 2 To lastRow
            customerNo = .Cells(rowIndex, 1).Value
            customerName = .Cells(rowIndex, 2).Value
            emailAddress = .Cells(rowIndex, 6).Value
            If Not dicCustomers.exists(customerNo) Then
                With .Range("A1:E" & lastRow) 'exclude email address from range
                    .AutoFilter field:=1, Criteria1:=customerNo
                    Set rngFilter = .SpecialCells(xlCellTypeVisible)
                    EmailCustomer olApp, rngFilter, emailAddress, subject
                    dicCustomers.Add Key:=customerNo, Item:=customerName
                    .AutoFilter
                End With
                Set rngFilter = Nothing
                DoEvents
            End If
        Next rowIndex
    End With
 
    Set wsSource = Nothing
    Set dicCustomers = Nothing
    Set olApp = Nothing
 
End Sub

Sub EmailCustomer(ByVal olApp As Object, ByVal rng As Range, ByVal emailAddress As String, ByVal subject As String)

    Dim olMailItem As Object
 
    Set olMailItem = olApp.createitem(0)
  
    DoEvents
 
    With olMailItem
        .display 'must be displayed before being able to paste
        DoEvents
        .To = emailAddress
        .subject = subject
        rng.Copy
        DoEvents
        With .getinspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
        DoEvents
        '.Send
        DoEvents
    End With
 
End Sub
 
Upvote 0
I think this document might be useful to you.

Distribute records in an Excel spreadsheet via email

This task is used to distribute the records in an Excel spreadsheet to each recipient.

Step1: Edit a table like the one below.
1.jpg


You can use Excel formulas in the spreadsheet to generate the email body, subject or other contents.

Step2: Run the Email Distribution task.
2.jpg

Step3: In the task interface, import your Excel spreadsheet, and the system will convert each record in the spreadsheet into an email to be sent to the corresponding recipient.
3.jpg

4.jpg


You can also process the records through simple SQL statements before sending them. For example, you can group records with the same email address into one table and send them in a single email to that address, instead of sending them as multiple separate emails.

I hope this response is helpful to you.
 
Upvote 0
Domenic said:
Yeah, okay, it must be a timing issue. So I've taken a closer look at the code, and I've amended it. I've added DoEvents at various locations. Does this help?

VBA Code: 
Option Explicit

Sub SendEmailsByCustomer()

    Dim dicCustomers As Object
    Dim olApp As Object
    Dim wsSource As Worksheet
    Dim rngFilter As Range
    Dim lastRow As Long
    Dim rowIndex As Long
    Dim customerNo As String
    Dim customerName As String
    Dim emailAddress As String
    Dim subject As String
 
    Set wsSource = ActiveSheet
 
    With wsSource
        If .FilterMode Then .ShowAllData
    End With
 
    With wsSource
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
 
    Set dicCustomers = CreateObject("Scripting.Dictionary")
 
    Set olApp = CreateObject("Outlook.Application")
 
    subject = "MySubject" 'change as desired
 
    With wsSource
        For rowIndex = 2 To lastRow
            customerNo = .Cells(rowIndex, 1).Value
            customerName = .Cells(rowIndex, 2).Value
            emailAddress = .Cells(rowIndex, 6).Value
            If Not dicCustomers.exists(customerNo) Then
                With .Range("A1:E" & lastRow) 'exclude email address from range
                    .AutoFilter field:=1, Criteria1:=customerNo
                    Set rngFilter = .SpecialCells(xlCellTypeVisible)
                    EmailCustomer olApp, rngFilter, emailAddress, subject
                    dicCustomers.Add Key:=customerNo, Item:=customerName
                    .AutoFilter
                End With
                Set rngFilter = Nothing
                DoEvents
            End If
        Next rowIndex
    End With
 
    Set wsSource = Nothing
    Set dicCustomers = Nothing
    Set olApp = Nothing
 
End Sub

Sub EmailCustomer(ByVal olApp As Object, ByVal rng As Range, ByVal emailAddress As String, ByVal subject As String)

    Dim olMailItem As Object
 
    Set olMailItem = olApp.createitem(0)
 
    DoEvents
 
    With olMailItem
        .display 'must be displayed before being able to paste
        DoEvents
        .To = emailAddress
        .subject = subject
        rng.Copy
        DoEvents
        With .getinspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
        DoEvents
        '.Send
        DoEvents
    End With
 
End Sub
Click to expand...

I have now amended the code and I get the same error message but it has changed the line the error occurs on...

1720074022107.png


/Skovgaard
 
Upvote 0
It still looks like a timing issue to me. I should have probably called PauseMacro instead of DoEvents, so that that it pauses the macro in addition to calling DoEvents. So let's try it by replacing each call to DoEvents with a call to PauseMacro. And, let's start by pausing it for 3 seconds. If it works, then you can try experimenting by pausing it for 1 or 2 seconds to see if it would suffice. You'll notice that I've moved rng.copy before the With/End With statement. Does this help?

VBA Code: 
Option Explicit

Sub SendEmailsByCustomer()

    Dim dicCustomers As Object
    Dim olApp As Object
    Dim wsSource As Worksheet
    Dim rngFilter As Range
    Dim lastRow As Long
    Dim rowIndex As Long
    Dim customerNo As String
    Dim customerName As String
    Dim emailAddress As String
    Dim subject As String
 
    Set wsSource = ActiveSheet
 
    With wsSource
        If .FilterMode Then .ShowAllData
    End With
 
    With wsSource
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
 
    Set dicCustomers = CreateObject("Scripting.Dictionary")
 
    Set olApp = CreateObject("Outlook.Application")
 
    subject = "MySubject" 'change as desired
 
    With wsSource
        For rowIndex = 2 To lastRow
            customerNo = .Cells(rowIndex, 1).Value
            customerName = .Cells(rowIndex, 2).Value
            emailAddress = .Cells(rowIndex, 6).Value
            If Not dicCustomers.exists(customerNo) Then
                With .Range("A1:E" & lastRow) 'exclude email address from range
                    .AutoFilter field:=1, Criteria1:=customerNo
                    Set rngFilter = .SpecialCells(xlCellTypeVisible)
                    EmailCustomer olApp, rngFilter, emailAddress, subject
                    dicCustomers.Add Key:=customerNo, Item:=customerName
                    .AutoFilter
                End With
                Set rngFilter = Nothing
                PauseMacro 3 'seconds
            End If
        Next rowIndex
    End With
 
    Set wsSource = Nothing
    Set dicCustomers = Nothing
    Set olApp = Nothing
 
End Sub

Sub EmailCustomer(ByVal olApp As Object, ByVal rng As Range, ByVal emailAddress As String, ByVal subject As String)

    Dim olMailItem As Object
 
    Set olMailItem = olApp.createitem(0)
 
    rng.Copy
   
    PauseMacro 3 'seconds
   
    With olMailItem
        .display 'must be displayed before being able to paste
        PauseMacro 3
        .To = emailAddress
        .subject = subject
        With .getinspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
        PauseMacro 3
        '.Send
        PauseMacro 3
    End With
 
End Sub

Sub PauseMacro(ByVal secs As Long)

    Dim endTime As Single
    endTime = Timer + secs
 
    Do
        DoEvents
    Loop Until Timer > endTime
 
End Sub
 
Upvote 0
Domenic said:
That's interesting, when I tested the code it seemed to work...

View attachment 112681

In any case, to add a signature that you've already set up, try the following....

1) Add the following code to your module...

VBA Code: 
Public Function FileExists(ByVal sFullname As String) As Boolean

    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
   
    FileExists = FSO.FileExists(sFullname)
   
    Set FSO = Nothing
   
End Function

Public Function GetBoiler(ByVal sFile As String) As String

    Dim FSO As Object
    Dim ts As Object
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
   
    GetBoiler = ts.readall
   
    ts.Close
   
End Function

2) Then amend your code as follows...

VBA Code: 
    Dim signatureFileName As String
    Dim signatureHTML As String
   
    signatureFileName = Environ("appdata") & "\Microsoft\Signatures\MySignature.htm" 'change the file name (MySignature.htm) accordingly

    If FileExists(signatureFileName) Then
        signatureHTML = GetBoiler(signatureFileName)
    Else
        signatureHTML = ""
    End If

    With olMailItem
        .Display 'must be displayed before being able to paste
        .To = EmailAddress
        .Subject = Subject
        .HTMLBody = "<p>This is the body of the email...</p>"
        Rng.Copy
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
        .HTMLBody = .HTMLBody & signatureHTML
        '.Send
    End With

Hope this helps!
Click to expand...
Hi Dom,
I know this is a bit of an old thread, but I'm wondering if you can assist me on one of my posts? It's fairly similiar to this, but including folders.
www.mrexcel.com

Excel VBA Macro to send emails & attachments

Hi, I need some help in putting together a macro which matches the excel files in a folder to the name in the main folder and send only those ones out. For example I have 10 excel files in my folder, let's say on the desktop: Each folder is named 'Person 1' through to 'Person 10' and in the...
www.mrexcel.com www.mrexcel.com
 
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Question
macro to filter spreadsheet by customer code, send relevant data via email
Replies
2
Views
448
Peter_SSs
Peter_SSs
C
  • Question
Create code that sends emails and creates a log
Replies
1
Views
122
cokeoverpepsi123
C
H
  • Question
VBA split file based and send splitted file in separate emails
Replies
0
Views
601
harmless92
H
B
  • Question
Send email to specific name that meets weeknumber criteria
Replies
0
Views
133
Birdy01962
B
S
  • Question
Filter Pivot, save as separate file, then email it
Replies
0
Views
435
skandall
S

Forum statistics

Threads
1,220,965
Messages
6,157,119
Members
451,398
Latest member
rjsteward

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top