Add Email Hyperlink with VBA

[TFCJamieFay]

Hi All,

I have a sheet ("Sheet2") with email addresses in column K down to about 300 or so. I want to write a bit of code to add a email hyperlink to each cell. I want the email address as the cell value and I want the subject to be "Report for " & CompanyName

So far I have the following, I'm just missing the important bit!

Sub AddHyperlinks()

    Dim CompanyName As String
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Lastrow = Range("D" & Rows.Count).End(xlUp).Row
    
    Range("K2:K" & Latrow).Select
    For Each cell In Selection
        cell.Activate
        CompanyName = cell.Offset(0, -7).Value
        
        '...Insert code to add hyperlink
        
    Next cell
               
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub

Many thanks,

Jay

 

[ColinKJ]

Hi TFCJamieFay,

You could try something like this

Code:

Set OutApp = CreateObject("Outlook.Application")
On Error Resume Next
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.to = Activecell.text
.CC = ""
.BCC = ""
.Subject = "Report for " & CompanyName .body = body
.display
End With
On Error GoTo 0

ColinKJ

 

[TFCJamieFay]

Thanks for your reply ColinKJ, but I have been playing around with the macro recorder and have gone with the following. It seems to work OK. Maybe I should have tried that first. Thank you for your help though!

Here's my code to help anyone else out there (if it's not full of holes that is but it worked for me!)

Sub AddHyperlinks()

    Dim CompanyName As String
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Lastrow = Range("D" & Rows.Count).End(xlUp).Row
    
    Range("K2:K" & Lastrow).Select
    For Each cell In Selection
        cell.Select
        
        If cell.Value <> "" Then
            CompanyName = cell.Offset(0, -7).Value
            
            ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:= _
                "mailto:" & cell.Value & "?subject=Report%20for%20" & CompanyName, _
                TextToDisplay:=cell.Value
        End If
        
    Next cell
               
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub