Split table and send per email

[Skovgaard]

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.

/Skovgaard

 

[Domenic]

Here's one way to approach it. Note that the code assumes that the active sheet contains the data. I would suggest that you add some sort of validation to make sure that the correct sheet is the active sheet (ie. check for the correct headers, tab name, etc). Also, as it stands, the emails generated are only displayed, not sent. Once you're certain that the code works as it should, you can uncomment .Send to actually send the emails.

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
            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)
   
    With olMailItem
        .display 'must be displayed before being able to paste
        .To = emailAddress
        .subject = subject
        rng.Copy
        With .getinspector.WordEditor
            .Application.Selection.Paste
        End With
        '.Send
    End With
   
End Sub

Hope this helps!

 

[Skovgaard]

Here's one way to approach it. Note that the code assumes that the active sheet contains the data. I would suggest that you add some sort of validation to make sure that the correct sheet is the active sheet (ie. check for the correct headers, tab name, etc). Also, as it stands, the emails generated are only displayed, not sent. Once you're certain that the code works as it should, you can uncomment .Send to actually send the emails.

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
            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)
  
    With olMailItem
        .display 'must be displayed before being able to paste
        .To = emailAddress
        .subject = subject
        rng.Copy
        With .getinspector.WordEditor
            .Application.Selection.Paste
        End With
        '.Send
    End With
  
End Sub

Hope this helps!

Thanks Domenic, works perfectly!

/Skovgaard

 

[Domenic]

You're very welcome, and thanks for the feedback!

Cheers!

 

[Skovgaard]

You're very welcome, and thanks for the feedback!

Cheers!

Hi again Domenic,
I want to bring this a step further and have tried different things...
When I try to put in a text in the email body, the selected range are being pasted in before the text. How do I rework your code to put in a body text before the pasted object?
Furthermore, is it possible to include the standard outlook signature in the email also?

/Skovgaard

 

[Domenic]

Maybe something like this...

    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 & "<p>Thank you,<br>John Smith</p>"
        '.Send
    End With

Hope this helps!

 

[Domenic]

Furthermore, is it possible to include the standard outlook signature in the email also?

Do you mean that you have a signature already set up, and that you want to add that signature to the email?

 

[Skovgaard]

Do you mean that you have a signature already set up, and that you want to add that signature to the email?

Exactly

 

[Skovgaard]

Maybe something like this...

    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 & "<p>Thank you,<br>John Smith</p>"
        '.Send
    End With

Hope this helps!

Thanks the body text is now above the pasted object
Below part doesn't seem to work, but that's okay in case the standard signature can be inserted.

/Skovgaard

 

[Domenic]

That's interesting, when I tested the code it seemed to work...

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

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

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

    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!