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!