I’m trying to retain hyperlinks in an email generated using VBA, using the RangetoHTML function from Rondebruin’s website. The hyperlinks are all in a table column of a table that’s shown in the email body.

Using the original Rondebruin code, I am able to paste all the correct values shown in the original table but the column with hyperlinks is only showing the values and not activated hyperlinks (cannot be clicked on).

I’ve also tried the solutions recommended in this thread but they aren’t working for me: Retain hyperlinks after rangetohtml paste Outlook?.

I’ve also tried using .Cells(1).PasteSpecial xlPasteAll, , False, False but this messes up the AutoFilter component and does not send the correct rows to the correct recipient.

Can someone please help me with an amendment to the below code to get the hyperlinks activated within the table? Thank you!

Sub SendMultiplevFINAL()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim EmailStart As String
Dim EmailEnd As String

On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")

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

'Set filter sheet, you can also use Sheets("MySheet")
Set Ash = Sheets("Email Output")

'Set filter range and filter column (Column with names)
Set FilterRange = Ash.Range("A1:J" & Ash.Rows.Count)
FieldNum = 10    'Filter column = J because the filter range start in J

'Add a worksheet for the unique list and copy the unique list in A1
Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=Cws.Range("A1"), _
        CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
    For Rnum = 2 To Rcount

        'Filter the FilterRange on the FieldNum column
        FilterRange.AutoFilter Field:=FieldNum, _
                               Criteria1:=Cws.Cells(Rnum, 1).Value

        'Look for the mail address in the List worksheet
        mailAddress = ""
        On Error Resume Next
        mailAddress = Application.WorksheetFunction. _
                      VLookup(Cws.Cells(Rnum, 1).Value, _
                            Worksheets("List").Range("A1:B" & _
                            Worksheets("List").Rows.Count), 2, False)
        On Error GoTo 0
        
        'Look for the greeting name in the List worksheet
        GreetingName = ""
        On Error Resume Next
        GreetingName = Application.WorksheetFunction. _
                      VLookup(Cws.Cells(Rnum, 1).Value, _
                            Worksheets("List").Range("A1:C" & _
                            Worksheets("List").Rows.Count), 3, False)
        On Error GoTo 0
        
        EmailStart = "<p>" & "Hi " & GreetingName & _
        
        If mailAddress <> "" Then
        
        With Ash.AutoFilter.Range
            On Error Resume Next
            With .Resize(, .Columns.Count - 1)
                Set rng = .SpecialCells(xlCellTypeVisible)
            End With

            On Error GoTo 0
        End With
        
            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next
            With OutMail
                .To = mailAddress
                .CC = Sheets("Email Details").Range("CC").Value
                .Subject = Sheets("Email Details").Range("Subject").Value
                .HTMLBody = EmailStart & _
                    "<p align='left'><table><tbody><tr><td>" & RangetoHTML(rng) & "</td></tr></tbody></table></p><br>"

                .Display  'Or use Send
            End With
            On Error GoTo 0

            Set OutMail = Nothing
        End If
        

        'Close AutoFilter
        Ash.AutoFilterMode = False

    Next Rnum
End If
cleanup:
Set OutApp = Nothing
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

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

Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim Hlink As Hyperlink


TempFile = Environ$("temp") & "" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

' Copy the range and create a workbook to receive the data.
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).PasteSpecial xlPasteFormulas, , False, False
    .Cells(1).Select
    Application.CutCopyMode = False
    On Error Resume Next
    .DrawingObjects.Visible = True
    .DrawingObjects.Delete
    On Error GoTo 0
End With

For Each Hlink In rng.Hyperlinks
    TempWB.Sheets(1).Hyperlinks.Add _
    Anchor:=TempWB.Sheets(1).Range(Hlink.Range.Address), _
    Address:=Hlink.Address, _
    TextToDisplay:=Hlink.TextToDisplay

Next Hlink

' Publish the sheet to an .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 the RangetoHTML subroutine.
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.
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function

Example of Excel Output Table