VBA to email multiple addresses with unique attachments

[MM2024]

I have used the code in the below thread successfully but I need to add an attachment to each email. The filepath for each attachment is in excel (column C) but I can't seem to get the code to pick up the required cell. Please help.

vba, Email multiple addresses with multiple rows

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

www.mrexcel.com

 

[mumps]

I have used the code in the below thread

Please use code tags to post the code that you are currently using.

 

[MM2024]

This is the code I'm currently using. Where I have .Attachments.Add Range("C2").Value I don't actually just want to pick up a fixed cell as it currently is, I want to pick up the cell (3rd column in my spreadsheet) associated with the row being emailed.

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 = Range("K1").Value & " Invoice " & v(i, 1)
                    .HTMLBody = "Insert your message here." & "<br>" & "More message"
                    .Display
                    .Attachments.Add Range("C2").Value
                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

 

[mumps]

Please post what the value of cell C2 looks like. Also, the macro filters the data based on the unique values in column A. However, you don't include the filtered data in your email. Is this the case?

 

[MM2024]

Thanks for your reply. Here are the example values being used. (I'm not sure what you mean by 'filtered' data sorry)

 

[MM2024]

To add to my post, C2 is the file path: C:\Users\an\Documents\doc.docx and this is unique to each user in the table.

 

[MM2024]

Think I might have just figured it out.

Up the top I changed .Resize(, 2) to .Resize(, 3) and then I was able to successfully change the .Attachments.Add Range("C2").Value to .Attachments.Add v(i, 3) and it is working.

 

[mumps]

Glad it worked out.