send multiple emails with spreadsheet attachments with a macro

[atditiljazi]

hello,

i currently use a macro to send multiple emails and i want it tweaked so it sends it as an attachment, not in the body of the email. i cant seem to amend it. can anyone help? my macro is below

Sub create_multiple_emails()
Dim sh As Worksheet
Dim c As Range, rng As Range
Dim dic As Object
Dim lr As Long

Set sh = Sheets("order book")
Set dic = CreateObject("scripting.dictionary")
If sh.AutoFilterMode Then sh.AutoFilterMode = False
lr = sh.Range("g" & Rows.Count).End(xlUp).Row

For Each c In sh.Range("g2:g" & lr)
If Not dic.exists(c.Value) Then
dic(c.Value) = dic(c.Value)
sh.Range("A1:z" & lr).AutoFilter 7, c.Value
Set rng = sh.Range("A1:H" & lr)
With CreateObject("Outlook.Application").CreateItem(0)
.To = c.Value
.Subject = "Subject"
.HTMLBody = RangetoHTML(rng)
'.Send 'to send
.display 'to show
End With
End If
Next
sh.ShowAllData
End Sub

Function RangetoHTML(rng As Range)
Dim fso As Object, ts As Object
Dim TempFile As String, TempWB As Workbook

TempFile = Environ$("temp") & "\temp.htm"
'Copy the range and create a new workbook to past the data in
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

'Publish the sheet to a htm file
With TempWB.PublishObjects.Add(xlSourceRange, TempFile, TempWB.Sheets(1).Name, TempWB.Sheets(1).UsedRange.Address, xlHtmlStatic)
.Publish (True)
End With

'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", "align=left xublishsource=")

'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

 

[mwperkins]

How about this:

Sub create_multiple_emails()
Dim sh As Worksheet
Dim c As Range, rng As Range
Dim dic As Object
Dim lr As Long


Dim strThisLocation As String, strThisBook As String
Dim strTempBook As String, TempWB As Workbook
Dim strTempFilename As String


'Remember where I started
strThisLocation = ActiveWorkbook.Path
strThisBook = ActiveWorkbook.Name
strThisSheet = ActiveSheet.Name

Set sh = Sheets("order book")
Set dic = CreateObject("scripting.dictionary")
If sh.AutoFilterMode Then sh.AutoFilterMode = False
lr = sh.Range("g" & Rows.Count).End(xlUp).Row

For Each c In sh.Range("g2:g" & lr)
If Not dic.exists(c.Value) Then
dic(c.Value) = dic(c.Value)
sh.Range("A1:z" & lr).AutoFilter 7, c.Value
Set rng = sh.Range("A1:H" & lr)

'Copy required info to a new file
strTempFilename = Environ$("temp") & "\report.xlsx"
'Copy the range and create a new workbook to past the data in
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


'Save the Temp file
ActiveWorkbook.SaveAs Filename:=strTempFilename, FileFormat:=xlOpenXMLWorkbook
strTempBook = ActiveWorkbook.Name

'Close Temp File
Workbooks(strTempBook).Close SaveChanges:=True

'Go back to where I started
Workbooks(strThisBook).Activate
Sheets(strThisSheet).Select



With CreateObject("Outlook.Application").CreateItem(0)
.To = c.Value
.Subject = "Subject"
.body = "Please find report attached"
.Attachments.Add strTempFilename
'.Send 'to send
.display 'to show
End With

'delete the temp file
Kill strThisLocation & "\" & strTempFilename & ".xlsx"


End If
Next
sh.ShowAllData
End Sub

 

[atditiljazi]

the code does not work for my spreadsheet. it tries to save the file and it also filters all the rows.

 

[atditiljazi]

here is a photo of my spreadsheet. i also had to tweak it so the link between the supplier code and email address does not work. any help amending it would be great. i had to add more columns as well so they will need to be included.

 

[Sequoyah]

Hi atditiljazi,
try this code

Option Explicit

Sub test20221129()
'https://www.mrexcel.com/board/threads/send-multiple-emails-with-spreadsheet-attachments-with-a-macro.1223276/
    
Dim rng             As Range, c As Range, i As Long, v As Variant, lastRow As Long
Dim targetWorkbook  As Workbook
Dim objFSO          As Object
Dim varTempFolder   As Variant
Dim AttFile         As String
    
lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
v = Range("A2:Z" & lastRow).Value        '<<==== Change last column is needed

Set objFSO = CreateObject("Scripting.FileSystemObject")
varTempFolder = objFSO.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss")
objFSO.CreateFolder (varTempFolder)

Application.ScreenUpdating = False

With CreateObject("scripting.dictionary")
    
    For i = 2 To UBound(v)
        If Not .exists(v(i, 7)) Then
            .Add v(i, 7), Nothing
            
            With ActiveSheet
                .Range("A1").AutoFilter 7, v(i, 7)
                Set rng = .AutoFilter.Range
                Set targetWorkbook = Workbooks.Add
                .UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(Sheets.Count).Range("A1")
                AttFile = v(i, 7) & ".xlsx"
                
                With targetWorkbook
                    .ActiveSheet.Columns.AutoFit
                    .SaveAs varTempFolder & "\" & AttFile
                    .Close
                End With
                
                With CreateObject("Outlook.Application").CreateItem(0)
                    .To = v(i, 14)        '<<=== email address in column N
                    .Subject = "Subject"
                    .Body = "Please find..."
                    .Attachments.Add varTempFolder & "\" & AttFile
                    '.Send 'to send
                    .display        'to show
                End With
                
            End With
        End If
    Next i
End With

Range("A1").AutoFilter

Application.ScreenUpdating = True
End Sub

 

[atditiljazi]

hi Sequoyah, this code does work but its not 100% as I wanted, your code sends emails to every line. I didn't make my self clear, I wanted to email each supplier (column F) with all the rows that relates to them as an attachment, not individually. could your vba code be changed?

if its possible, i would like to keep all the email address's in (sheet2), so it isn't in main orderbook sheet, and the macro will identify the email address that links with the supplier code in (orderbook sheet column F)

sheet 2 example
A B

1) supplier	email Address
2) a	a@a.com
3) b	b@b.com
4) c	c@c.com
5) d	d@d.com

​

i really appreciate your help

 

[Sequoyah]

Hi atditiljazi,
here's my new attempt

Sub test20221130()
'https://www.mrexcel.com/board/threads/send-multiple-emails-with-spreadsheet-attachments-with-a-macro.1223276/
    
Dim rng             As Range, c As Range, AddrRange As Range
Dim i               As Long, lastRow As Long, lastRow2 As Long
Dim targetWorkbook  As Workbook
Dim objFSO          As Object
Dim varTempFolder   As Variant, v As Variant
Dim AttFile         As String, Dest As String
Dim sh              As Worksheet, shMail As Worksheet

Set sh = Sheets("order book")
Set shMail = Sheets(2)

lastRow = sh.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
lastRow2 = shMail.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set AddrRange = shMail.Range("A1:B" & lastRow2)

v = sh.Range("A2:Z" & lastRow).Value        '<<==== Change last column is needed

Set objFSO = CreateObject("Scripting.FileSystemObject")
varTempFolder = objFSO.GetSpecialFolder(2).Path & "\Temp " & Format(Now, "dd-mm-yyyy- hh-mm-ss")
objFSO.CreateFolder (varTempFolder)

Application.ScreenUpdating = False

With CreateObject("scripting.dictionary")
    
    For i = 2 To UBound(v)
        If Not .exists(v(i, 6)) Then
            .Add v(i, 6), Nothing
            
            With sh
                .Range("A1").AutoFilter 6, v(i, 6)
                Set rng = .AutoFilter.Range
                Set targetWorkbook = Workbooks.Add
                .UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(Sheets.Count).Range("A1")
                AttFile = v(i, 6) & ".xlsx"
                Dest = Application.WorksheetFunction.VLookup(v(i, 6), AddrRange, 2, False)
                
                With targetWorkbook
                    .ActiveSheet.Columns.AutoFit
                    .SaveAs varTempFolder & "\" & AttFile
                    .Close
                End With
                
                With CreateObject("Outlook.Application").CreateItem(0)
                    .To = Dest
                    .Subject = "Subject"
                    .Body = "Please find..."
                    .Attachments.Add varTempFolder & "\" & AttFile
                    .display        'to show
                    '.Send 'to send
                End With
                
            End With
        End If
        
    Next i
End With

Range("A1").AutoFilter
Application.ScreenUpdating = True

objFSO.deletefolder (varTempFolder)
End Sub

 

[atditiljazi]

hi Sequoyah. you are a star!!! i have just done a test and it worked. i will test it again shorty. i tried to create a button on a separate sheet called (home) but it wouldn't work. i had an error called 400. do i have to create a button in the order book sheet?

 

[atditiljazi]

one more thing. if i ever need to move column F to another column, where in the macro do i change the information?

 

[Sequoyah]

Hi @atditiljazi, thanks for the feedback. If you have more then two sheets in your workbook, change these line of code, so you will be able to insert a command button in your sheet "Home":

Set shMail = Sheets(2)

with

Set shMail = Sheets("MySheet") ' <<====  the exact name of the sheet

and

Range("A1").AutoFilter

with

sh.Range("A1").AutoFilter

Column F is the sixth column in the sheet, if you need to manage a different column change the 6 wherever it appears in the code to the appropriate number