Re: Upgrade existing macro to send data from multiple rows in one email
Try this out... I used a sort as I previously referenced, some code from Ron De Bruin to convert your ranges into HTML and pretty much the same email code you had. I set the code to only display emails rather than send....
If you want to suppress annoying email message you'll have to work with the CDO code (I've only used this on a few occasions so I'm no pro either... Took me several hours of debugging to get it to work for my purposes.)
Probably a better way to go about it...but, this is what I came up with (Feel free to improve and post back)
Sub Client_Update_sample()
Dim Lrow As Long
Dim TopRow As Long
Dim BottomRow As Long
Dim MultCllRng As Boolean
Dim MyHTMLRng As Range
Dim IntLp As Integer
Dim IntLpTwo As Integer
On Error GoTo 0
Lrow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
'Sort Yes to and then Sort DM
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("G2")
.SortFields.Add Key:=Range("F2")
.SetRange Range("A1:G21")
.Header = xlYes
.Apply
End With
For IntLp = Lrow To 2 Step -1
If Cells(IntLp, "G") = "Yes" Then
TopRow = IntLp
If Cells(IntLp, "F") <> Cells(IntLp - 1, "F") Then
BottomRow = IntLp
Set MyHTMLRng = Range("A1:E1, " & "A" & TopRow & ":E" & BottomRow)
Call SendEmail(MyHTMLRng, Cells(IntLp, "C"))
Else
For IntLpTwo = IntLp To 2 Step -1
If Cells(IntLpTwo, "F") <> Cells(IntLpTwo - 1, "F") Then
BottomRow = IntLpTwo
Set MyHTMLRng = Range("A1:E1, " & "A" & TopRow & ":E" & BottomRow)
Call SendEmail(MyHTMLRng, Cells(IntLpTwo, "C"))
IntLp = BottomRow
Exit For
End If
Next IntLpTwo
End If
End If
Next IntLp
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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"
'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( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=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 x:publishsource=", _
"align=left x:publishsource=")
'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
Sub SendEmail(MyHTMLRng As Range, myClientRng As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim OutlookOpened As Boolean
OutlookOpened = False
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Set OutApp = CreateObject("Outlook.Application")
OutlookOpened = True
End If
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "[email protected]"
.cc = "[email protected]; [email protected]"
.Subject = "New Clients for " & myClientRng.Value
.htmlbody = RangetoHTML(MyHTMLRng)
.Display 'allows email to be displayed and checked before manually sending it
'.Send
End With
On Error GoTo 0
Set OutMail = Nothing
If OutlookOpened Then OutApp.Quit
Set OutApp = Nothing
End Sub
Display More
