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

 

[VKMouli]

Sir, i also got still the same error after added button and said above changes. can you re check once

 

[atditiljazi]

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

hi Sequoyah

sorry for late reply back, i have only managed to work on this due to medical reason. i really do appreciate your help.

i changed the codes and when i do a practice run, the header row is stretched down, looks like the image below. ( the file is the attached spreadsheet in the email)

its suppose to look like this,

here is the macro,


Sub test20221130()

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("Sheet2")

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:v" & lastRow).Value

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, 2)) Then
.Add v(i, 2), Nothing

With sh
sh.Range("A1").AutoFilter 2, v(i, 2)
Set rng = .AutoFilter.Range
Set targetWorkbook = Workbooks.Add
.UsedRange.SpecialCells(xlCellTypeVisible).Copy targetWorkbook.Worksheets(Sheets.Count).Range("A1")
AttFile = v(i, 2) & ".xlsx"
Dest = Application.WorksheetFunction.VLookup(v(i, 2), 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 the attached order book. please fill in the column that applies to you"
.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

 

[Sequoyah]

Hi atditiljazi
below the macro modified as per your request

Sub test20221130B()

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("Sheet2")

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:v" & lastRow).Value

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, 2)) Then
.Add v(i, 2), Nothing

With sh
sh.Range("A1").AutoFilter 2, v(i, 2)
Set rng = .AutoFilter.Range
Set targetWorkbook = Workbooks.Add
.UsedRange.SpecialCells(xlCellTypeVisible).Copy
                
                 With targetWorkbook.Worksheets(Sheets.Count)
                    .Range("A1").PasteSpecial xlPasteColumnWidths
                    .Range("A1").PasteSpecial xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    .Range("A1").PasteSpecial xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                End With
                
AttFile = v(i, 2) & ".xlsx"
Dest = Application.WorksheetFunction.VLookup(v(i, 2), 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 the attached order book. please fill in the column that applies to you"
.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,

thank you very much., this works perfectly. You have been a real help!

 

[atditiljazi]

Hi atditiljazi
below the macro modified as per your request

Sub test20221130B()

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("Sheet2")

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:v" & lastRow).Value

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, 2)) Then
.Add v(i, 2), Nothing

With sh
sh.Range("A1").AutoFilter 2, v(i, 2)
Set rng = .AutoFilter.Range
Set targetWorkbook = Workbooks.Add
.UsedRange.SpecialCells(xlCellTypeVisible).Copy
               
                 With targetWorkbook.Worksheets(Sheets.Count)
                    .Range("A1").PasteSpecial xlPasteColumnWidths
                    .Range("A1").PasteSpecial xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                    .Range("A1").PasteSpecial xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                End With
               
AttFile = v(i, 2) & ".xlsx"
Dest = Application.WorksheetFunction.VLookup(v(i, 2), 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 the attached order book. please fill in the column that applies to you"
.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

hi Sequoyah

the practice run was ok but when I went to use it properly for the first time with 100+ emails, it would stop halfway through and an error box with a 400 code would appear. what could be causing this issue?

 

[Sequoyah]

Hi atditiljazi
the only suggestion I can give you, if you haven't done it yet, is to avoid displaying the email and send it directly by changing the following lines of code

'.display 'to show
.Send 'to send

Also you can try to add a time interval between sendings by adding this line

Application.Wait (Now + TimeValue("0:00:01"))

before the line

Next i

 

[atditiljazi]

all sorted, I had a spelling mistake on a supplier name to cross-reference the email address!

 

[atditiljazi]

Hi atditiljazi
the only suggestion I can give you, if you haven't done it yet, is to avoid displaying the email and send it directly by changing the following lines of code

'.display 'to show
.Send 'to send

Also you can try to add a time interval between sendings by adding this line

Application.Wait (Now + TimeValue("0:00:01"))

before the line

Next i

hi Sequoyah,

sorry, but I have 1 more question and I hope you don't mind me keep asking for help. I would like to CC people and the email address will be located in sheet2 column C. where would i amend the macro?

kind regards.