vba, Email multiple addresses with multiple rows

[Auke]

Hello, my first post.
I'm looking for a solution with my Excel VBA problem.
Hopefully someone is able to help.

I'm looking for a solution to send multiple emails with outlook to different mailadresses with different rows from my excel file.

Employee name	Email address	Info 1	Info 2	Info 3	Info 4	Info 5	Info 6	Info 7
A	A@hotmail.com	A	B	C	D	Info 5	Info 6	Info 7
A	A@hotmail.com	A	B	C	D	Info 5	Info 6	Info 7
B	B@hotmail.com	A	B	C	D	Info 5	Info 6	Info 7
B	B@hotmail.com	A	B	C	D	Info 5	Info 6	Info 7
C	C@hotmial.com	A	B	C	D	Info 5	Info 6	Info 7
C	C@hotmial.com	A	B	C	D	Info 5	Info 6	Info 7

So every employee needs to receive an email with only the rows applying to them.
In this example every employee will receive an email with 3 excel rows in in, the header and the 2 rows related to his name and mailadress.

Is someone able to help me with the code for this?
I've been searching, but I were not able to find the right coding.

Thanks in advance.

Kind regards, Auke

 

[mumps]

Place this code in a standard module and run it from there. Change the subject (in red) to suit your needs. Change Display (in blue) to Send if you want to send the emails automatically without seeing them first.

Sub CreateEmails()
    Dim OutApp As Object, OutMail As Object, v As Variant, i As Long, rng As Range
    v = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
      For i = LBound(v) To UBound(v) 'loops through rows
         If Not .exists(v(i, 1)) Then
            .Add v(i, 1), Nothing
            With ActiveSheet
                .Range("A1").AutoFilter 1, v(i, 1)
                Set rng = .AutoFilter.Range
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = v(i, 2)
                    .Subject = "This is a test message"
                    .HTMLBody = RangetoHTML(rng)
                    .Display
                End With
            End With
        End If
      Next i
      ActiveSheet.Range("A1").AutoFilter
   End With
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[Auke]

Hi Mumps,

Thanks for your reply! It worked immediately!
2 more questions.
How can I write a bit of email text before the table?
And is it possible to format 2 specific colums to date-formatting instead of number formatting?

 

[mumps]

And is it possible to format 2 specific colums to date-formatting instead of number formatting?

Format the two columns in your sheet as "Date" before running the macro.

Replace the current line of code with this one and change the part in red to suit your needs.

.HTMLBody = "Insert your message here." & "<br>" & RangetoHTML(rng)

 

[cvcc_wt]

Format the two columns in your sheet as "Date" before running the macro.

Replace the current line of code with this one and change the part in red to suit your needs.

.HTMLBody = "Insert your message here." & "<br>" & RangetoHTML(rng)

Is there anyway to add column A's information to the subject line? So, the subject could say something like "Information for Employee A" or "Employee's A Sales List"? I'm so happy I found your code!

 

[mumps]

Replace this line of code:

.Subject = "This is a test message"

with this line:

.Subject = "Information for Employee " & v(i, 1)

 

[cvcc_wt]

Replace this line of code:

.Subject = "This is a test message"

with this line:

.Subject = "Information for Employee " & v(i, 1)

Thank you for this. I'm new to VBA in Excel so this was lost on me. But, your code is clean and so it was easy to locate.

 

[mumps]

You are very welcome.

 

[kakdativikam]

Place this code in a standard module and run it from there. Change the subject (in red) to suit your needs. Change Display (in blue) to Send if you want to send the emails automatically without seeing them first.

Sub CreateEmails()
    Dim OutApp As Object, OutMail As Object, v As Variant, i As Long, rng As Range
    v = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
      For i = LBound(v) To UBound(v) 'loops through rows
         If Not .exists(v(i, 1)) Then
            .Add v(i, 1), Nothing
            With ActiveSheet
                .Range("A1").AutoFilter 1, v(i, 1)
                Set rng = .AutoFilter.Range
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = v(i, 2)
                    .Subject = "This is a test message"
                    .HTMLBody = RangetoHTML(rng)
                    .Display
                End With
            End With
        End If
      Next i
      ActiveSheet.Range("A1").AutoFilter
   End With
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Hi mumps,

I'm an absolute beginner when it comes to VBA, so I'd appreciate some guidance with this.

I have been trying to adapt this to work with a condition, that would check the status in the 6th (F) column - Finished or Not Finished (8th also works, with 1 and 0 instead) and only include rows containing Not Finished (0), but I've been met with multiple errors instead. Subscript out of range for example or Mismatch type 13.

Thank you in advance.

 

[mumps]

Try:

Sub CreateEmails()
    Dim OutApp As Object, OutMail As Object, rng As Range
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    With ActiveSheet
        .Range("A1").AutoFilter 6, "Not Finished"
        Set rng = .AutoFilter.Range
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
            .To = ""
            .Subject = "This is a test message"
            .HTMLBody = RangetoHTML(rng)
            .Display
        End With
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = False
End Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function