Emailing a Variable Range as HTML

[phill63]

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?

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

 

[John_w]

Try changing:

Set rng = Sheets("Missing Accounts").Range("A2:C2" & LR)

to:

Set rng = Sheets("Missing Accounts").Range("A2:C" & LR)

 

[phill63]

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.

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