Emailing a Variable Range as HTML

phill63

New Member
Joined
Dec 9, 2013
Messages
9
Hi all so first of all the below code is an adaption of one from Ron de Bruin and not my own code.

I have a spreadsheet that has accounts number and information in columns A:D

I have Macro Buttons in row one and my column headers in row 2.

What I want to do is email A:C from row 2 to the last row that has information in column A. I tried changing the range of the code to go to the last row but it just goes on to infinity and emails a huge range of blank cells after the data I need.

Any ideas where I went wrong and how to fix it?

Code:
Sub EmailMissingAccounts()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim WB As Workbook
    Dim LR As String
    Set WB = ThisWorkbook
    LR = WB.Worksheets("Missing Accounts").Cells(Rows.Count, "A").End(xlUp).Row
    
    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("Missing Accounts").Range("A2:C2" & LR)
    On Error GoTo 0


    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If


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


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


    On Error Resume Next
    With OutMail
        .to = "phillip.mangham@lpl.com"
        .CC = ""
        .BCC = ""
        .Subject = "New Accounts Missing From Vestmark"
        .Body = RangetoHTML(rng)
        .Send
    End With
    On Error GoTo 0


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


    Set OutMail = Nothing
    Set OutApp = Nothing
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
 
Last edited:

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,718
Try changing:
Code:
Set rng = Sheets("Missing Accounts").Range("A2:C2" & LR)
to:
Code:
Set rng = Sheets("Missing Accounts").Range("A2:C" & LR)
 
Upvote 0

phill63

New Member
Joined
Dec 9, 2013
Messages
9
Once again thank you John. Worked like a charm.

I am having one small and insignificant issue still. If you can spot the bug in my code it would be appreciated.

It is now emailing the right range but the last row always has the bottom border missing. The borders are there on the spreadsheet but for some reason the bottom border doesn't make the cut to the HTML in the email. I am guessing it has something to do with the way I am having VBA format the borders (which I almost directly took from the recorder as I haven't messed around with or read the chapters yet about formatting stuff). If you have any ideas as to what might fix this or a better way to go about adding borders as always it would be appreciated.

Code:
Option Explicit
Sub MissingAccounts()
    
    Dim i As Integer
    Dim WB As Workbook
    Dim LR As String
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    Set WB = ThisWorkbook
    LR = WB.Worksheets("Missing Accounts").Cells(Rows.Count, "A").End(xlUp).Row
    
    If LR <> 2 Then
        
        For i = LR To 3 Step -1
          
            If WB.Worksheets("Missing Accounts").Range("A" & i).Value <> "" Then
                WB.Worksheets("Missing Accounts").Range("D1").Copy
                WB.Worksheets("Missing Accounts").Range("D" & i).PasteSpecial Paste:=xlPasteFormulas
            End If
          
        Next i
         
        Application.CutCopyMode = False
        
        For i = LR To 3 Step -1
            
            If WB.Worksheets("Missing Accounts").Range("D" & i).Value = "Loaded" Then
                WB.Worksheets("Missing Accounts").Range("D" & i).EntireRow.Delete
            End If
        Next i
        
    End If
    
    
    Range("A2:D250").Select
    ActiveWorkbook.Worksheets("Missing Accounts").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Missing Accounts").Sort.SortFields.Add Key:=Range( _
        "C3:C250"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Missing Accounts").Sort
        .SetRange Range("A2:D250")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    
    Cells.Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Application.CutCopyMode = False
    
    Call EmailMissingAccounts
    
    WB.Sheets("Accounts In Vestmark").Range("A2:A1000").ClearContents
    
    WB.Close Savechanges:=True
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True


End Sub


Sub EmailMissingAccounts()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim LR As String
    
    LR = Sheets("Missing Accounts").Cells(Rows.Count, "A").End(xlUp).Row
    
    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("Missing Accounts").Range("A2:C" & LR).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0


    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If


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


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


    On Error Resume Next
    With OutMail
        .to = "OMC_Support@lpl.com"
        .CC = "Matthew.Griego@lpl.com;Agata.Kolodziejcyk@lpl.com;Melissa.Mattern@lpl.com;Joel.Mattix@lpl.com"
        .BCC = ""
        .Subject = "New Accounts Not In Vestmark"
        .HTMLBody = RangetoHTML(rng)
        .Send
    End With
    On Error GoTo 0


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


    Set OutMail = Nothing
    Set OutApp = Nothing
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
 
Upvote 0

Forum statistics

Threads
1,187,091
Messages
5,961,531
Members
438,552
Latest member
Robyrubyjane

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top