Dynamic email macro based on cell location

nuckfuts

New Member
Joined
Mar 10, 2020
Messages
43
Office Version
  1. 365
Platform
  1. Windows
Hi All,

I wanted to create a =HYPERLINK email generator based on cell values in the active row but #VALUE reared its ugly head. It would work great if I didn't run into character limits, so now I must resort to macros.

The Recipient name, To: CC: Subject: Body: etc., will be filled in columns A, B, C, D, for example.
Each row will be for a different recipient, thus the above message components will vary row to row.
In the last columns (lets say column E), I'd like a hyperlink (or similar) to press and generate the email for that recipient.

Some values in the columns B, C, D containing the message components use CONCAT like if there are multiple "To" email addresses

Any help or ideas would be appreciated, essentially I'd like to run one macro that changes the above variables based on row value.
 

Some videos you may like

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type

ManiacB

Board Regular
Joined
Aug 11, 2020
Messages
56
Office Version
  1. 365
Platform
  1. Windows
Try the following, but instead of a link, type "send" into column H to execute the macro to send the email. Create the information with the headers aligned as shown below.
emr.png


Place the following code in the sheet1 code module:

VBA Code:
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("H:H")) Is Nothing Then
        If Target.Value = "send" Then
        i = Target.Row
        MsgBox "Send Mail on row " & i
        Call SendEmail(i)
        End If
    End If
End Sub


Sub SendEmail(i As Long)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lr As Integer
    Dim Path, strBody As String
    'Dim i As Long
    
    Application.ScreenUpdating = False

        On Error GoTo erHandle
            If Not IsEmail(Sheet1.Cells(i, "B").Value) Then
                Sheet1.Cells(i, "G").Value = "Bad Email"
                GoTo skip
            End If
            If IsEmpty(Cells(i, "G").Value) Then
                Set OutApp = CreateObject("Outlook.Application")
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = Sheet1.Cells(i, "A").Value
                    .CC = Sheet1.Cells(i, "B").Value
                    .BCC = Sheet1.Cells(i, "F").Value
                    .Subject = Sheet1.Cells(i, "C").Value
                    .HTMLBody = Sheet1.Cells(i, "D").Value
                    If Not IsEmpty(Sheet1.Cells(i, "E")) Then
                        .Attachments.Add Sheet1.Cells(i, "E").Value
                    End If
                    .Display    'DELETE THIS LINE IF USING SEND
                    '.send
                End With
            Sheet1.Cells(i, "G").Value = Date
            Set OutMail = Nothing
            Set OutApp = Nothing
            End If
skip:
    
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
Exit Sub
erHandle:
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
    On Error GoTo -1
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
    
End Sub
Function IsEmail(ByVal s As String) As Boolean
  Dim x As Long, AtSign As Long, Parts() As String
  Dim NotLocale As String, NotDomain As String
  NotLocale = "*[!A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]*"
  NotDomain = "*[!A-Za-z0-9._-]*"
  Parts = Split(s, "@")
  If UBound(Parts) <> 1 Then Exit Function
  If Parts(0) Like NotLocale Then Exit Function
  If Parts(1) Like NotDomain Then Exit Function
  IsEmail = True
End Function
 
Solution

nuckfuts

New Member
Joined
Mar 10, 2020
Messages
43
Office Version
  1. 365
Platform
  1. Windows
This
Try the following, but instead of a link, type "send" into column H to execute the macro to send the email. Create the information with the headers aligned as shown below.
View attachment 25516

Place the following code in the sheet1 code module:

VBA Code:
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i As Long
If Target.Cells.Count > 1 Then Exit Sub
    If Not Intersect(Target, Range("H:H")) Is Nothing Then
        If Target.Value = "send" Then
        i = Target.Row
        MsgBox "Send Mail on row " & i
        Call SendEmail(i)
        End If
    End If
End Sub


Sub SendEmail(i As Long)
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lr As Integer
    Dim Path, strBody As String
    'Dim i As Long
   
    Application.ScreenUpdating = False

        On Error GoTo erHandle
            If Not IsEmail(Sheet1.Cells(i, "B").Value) Then
                Sheet1.Cells(i, "G").Value = "Bad Email"
                GoTo skip
            End If
            If IsEmpty(Cells(i, "G").Value) Then
                Set OutApp = CreateObject("Outlook.Application")
                Set OutMail = OutApp.CreateItem(0)
                With OutMail
                    .To = Sheet1.Cells(i, "A").Value
                    .CC = Sheet1.Cells(i, "B").Value
                    .BCC = Sheet1.Cells(i, "F").Value
                    .Subject = Sheet1.Cells(i, "C").Value
                    .HTMLBody = Sheet1.Cells(i, "D").Value
                    If Not IsEmpty(Sheet1.Cells(i, "E")) Then
                        .Attachments.Add Sheet1.Cells(i, "E").Value
                    End If
                    .Display    'DELETE THIS LINE IF USING SEND
                    '.send
                End With
            Sheet1.Cells(i, "G").Value = Date
            Set OutMail = Nothing
            Set OutApp = Nothing
            End If
skip:
   
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
Exit Sub
erHandle:
    MsgBox "Error #" & Err.Number & vbCrLf & Err.Description
    On Error GoTo -1
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
    End With
   
End Sub
Function IsEmail(ByVal s As String) As Boolean
  Dim x As Long, AtSign As Long, Parts() As String
  Dim NotLocale As String, NotDomain As String
  NotLocale = "*[!A-Za-z0-9.!#$%&'*/=?^_`{|}~+-]*"
  NotDomain = "*[!A-Za-z0-9._-]*"
  Parts = Split(s, "@")
  If UBound(Parts) <> 1 Then Exit Function
  If Parts(0) Like NotLocale Then Exit Function
  If Parts(1) Like NotDomain Then Exit Function
  IsEmail = True
End Function
worked great! Did some tweaking but was exactly what I needed. Thanks!
 

Watch MrExcel Video

Forum statistics

Threads
1,128,165
Messages
5,629,068
Members
416,363
Latest member
zaveedd

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