Excel VBA - Emailing Range as Table to Correspond Email in a Column

votes

I have a spreadsheet with recipients name in column A, recipients email in column B and mulitple others columns with the information to be emailed to these recipients. Each recipient has multiple rows, and the number of rows per recipient varies each time. The number of recipients also varies.

What I would like to do is create only one email for each recipient and include the other data columns relevant to that recipient as a table at the end of the body of the email. All emails would have the same text in the body of the email which would be stored in the code and not in the spreadsheet.

Any help would be appreciated. This is my first time dealing with outlook through Excel VBA.

Thanks

vbaexcelemailoutlook

Can you show what the Spreadsheet looks like – 0m3r

2 Answers

votes

Add a reference to outlook library in VBA (in the toolbar ->Tools->References-Microsoft Outlook)
Recipients would be the filter (if the email is going to the same person, just stick all the thing that you want to say to him/her), so, why not to do a filter prior to get them in order in the first place?
After adding the reference, you are going to be available to use outlook commands, create instances, etc. There are many google examples, this one may be a good one to start with. This is my suggested workflow

votes

Thanks Sgdva. That was a good hint. I also used some code from Ron de Bruin to come up with the following solution.

This sub sets up my data and is not very relevant for the answer, but might be of use to someone.

Sub Related_BA()

Dim wb As Workbook
Dim ws As Worksheet
Dim filename As Variant
Dim returnVAlue As Variant
Dim BAwb As Workbook
Dim BAws As Worksheet
Dim BArng As Range
Dim LastRow As Integer
Dim i As Integer

Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Super User Report")

filename = Application.GetOpenFilename(filefilter:="Excel Files (*xls), *xls", Title:="Please select BA refernce file")
If filename = False Then Exit Sub

ws.Range("A:B").EntireColumn.Insert

Set BAwb = Application.Workbooks.Open(filename)
Set BAws = BAwb.Worksheets("Sheet1")
Set BArng = BAws.ListObjects("DepartmentBA").DataBodyRange

With ws.Cells(1, 1)
    .Value = "BA"
    .HorizontalAlignment = xlCenter
    .Font.Bold = True
End With

With ws.Cells(1, 2)
    .Value = "BA Email"
    .HorizontalAlignment = xlCenter
    .Font.Bold = True
End With

LastRow = ws.Range("C1").CurrentRegion.Rows.Count

On Error Resume Next
For i = 2 To LastRow
    ws.Cells(i, 1) = Application.WorksheetFunction.VLookup(ws.Cells(i, 6), BArng, 2, 0)
Next i

On Error Resume Next
For i = 2 To LastRow
    ws.Cells(i, 2) = Application.WorksheetFunction.VLookup(ws.Cells(i, 6), BArng, 3, 0)
Next i

BAwb.Close False

ws.Columns("A:B").EntireColumn.AutoFit

ws.Range("B2").CurrentRegion.Sort key1:=ws.Range("B2"), order1:=xlAscending, _
    key2:=ws.Range("C2"), order2:=xlAscending, Header:=xlYes

Call SendEmail

ws.Range("A:B").EntireColumn.Delete


End Sub

This formats the data for the email and calls the email function. I still might need code to handle #N/A from the vlookup.

Sub SendEmail()

Dim cBA As Collection
Dim rng As Range
Dim cell As Range
Dim wb As Workbook
Dim ws As Worksheet
Dim vNum As Variant
Dim lRow As Integer

Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Super User Report")
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = ws.Range("A2:A" & lRow)
Set cBA = New Collection

On Error Resume Next
    For Each cell In rng.Cells
        cBA.Add cell.Value, CStr(cell.Value)
    Next cell
On Error GoTo 0

On Error Resume Next
cBA.Remove ("None")

Worksheets("Super User Report").AutoFilterMode = False

For Each vNum In cBA
    rng.AutoFilter Field:=1, Criteria1:=vNum
    Call Email(vNum)
    rng.AutoFilter Field:=1
Next vNum


End Sub

This sube actually creates and sends the email.

Sub Email(BA As Variant)

Dim wb As Workbook
Dim ws As Worksheet
Dim lRow As Integer
Dim StrBody As String
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Mnth As Variant
Dim Yr As Variant

StrBody = "This is line 1" & "<br>" & _
          "This is line 2" & "<br>" & _
          "This is line 3" & "<br><br><br>"


Mnth = Format(Month(Date), "mmmm")
Yr = Year(Date)
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Super User Report")
lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = ws.Range("C1:L" & lRow).SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If rng Is Nothing Then
    Exit Sub
End If

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.Borders(xlDiagonalUp).LineStyle = xlNone
With rng.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With rng.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With rng.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With rng.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With rng.Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With rng.Borders(xlInsideHorizontal)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Mnth = Format(Month(Date), "mmmm")
Yr = Year(Date)

On Error Resume Next
With OutMail
    .To = BA
    .CC = ""
    .BCC = ""
    .Subject = "Monthly Super User Report " & Mnth & " " & Yr
    .HTMLBody = StrBody & RangetoHTML(rng)
    .Display   'or use .Send
End With
On Error GoTo 0

rng.Borders(xlDiagonalDown).LineStyle = xlNone
rng.Borders(xlDiagonalUp).LineStyle = xlNone
rng.Borders(xlEdgeLeft).LineStyle = xlNone
rng.Borders(xlEdgeTop).LineStyle = xlNone
rng.Borders(xlEdgeBottom).LineStyle = xlNone
rng.Borders(xlEdgeRight).LineStyle = xlNone
rng.Borders(xlInsideVertical).LineStyle = xlNone
rng.Borders(xlInsideHorizontal).LineStyle = xlNone

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

This function is referenced in the sub above.

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"

'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

I hope this is useful to someone.