Automatic Email Based on Excel Range Updates/Changes

Question

I have this excel macro that automatically sends an email when a cell is updated. I want to be able to send it to two different mailboxes based on cell update. For example if cell D5:D10 is updated the email gets sent to mailbox1, if cell D12:20 is updated the email gets sent to mailbox 2. I also want to include a folder path in the body message.

This is what I have so far:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xRgSel As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xMailBody As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set xRg = Range("D5:D34")
    Set xRgSel = Intersect(Target, xRg)
    ActiveWorkbook.Save
    If Not xRgSel Is Nothing Then
        Set xOutApp = CreateObject("Outlook.Application")
        Set xMailItem = xOutApp.CreateItem(0)
        xMailBody = "Hello," & vbCrLf & vbCrLf & Me.Range("B" & Target.Row)& " has been completed."
        With xMailItem
            .To = "email@email.com"
            .Subject = "subject"
            .Body = xMailBody
            .Display
        End With
        Set xRgSel = Nothing
        Set xOutApp = Nothing
        Set xMailItem = Nothing
    End If
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Answer 1

you can have a straightforward solution by simply splitting the watched ranges in two (or more). I'm not sure why you are saving the workbook after the change, but I place it inside the If-block, so you only have the workbook saved when the change is inside the watched ranges.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xRg01, xRgSel01, xRg02, xRgSel02 As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xMailBody, xFolderPath As String
    'On Error Resume Next
    '---------------------------------
    'get workbook path
    xFolderPath = ActiveWorkbook.Path
    '---------------------------------
    'Deal with first range
    Set xRg01 = Range("D5:D10")
    Set xRgSel01 = Intersect(Target, xRg01)
    If Not xRgSel01 Is Nothing Then
        ActiveWorkbook.Save
        Set xOutApp = CreateObject("Outlook.Application")
        Set xMailItem = xOutApp.CreateItem(0)
        xMailBody = "Hello," & vbCrLf & vbCrLf & "Cell D" & Target.Row & " has been changed, to value [" & Target.Value & "]." & vbCrLf & vbCrLf & "Workbook path:" & xFolderPath
        With xMailItem
            .To = "email@email.com"
            .Subject = "Subject for xRg01"
            .Body = xMailBody
            .Display
        End With
    End If
    '---------------------------------
    'Deal with the second range
    Set xRg02 = Range("D12:D20")
    Set xRgSel02 = Intersect(Target, xRg02)
    If Not xRgSel02 Is Nothing Then
        ActiveWorkbook.Save
        Set xOutApp = CreateObject("Outlook.Application")
        Set xMailItem = xOutApp.CreateItem(0)
        xMailBody = "Hello," & vbCrLf & vbCrLf & "Cell D" & Target.Row & " has been changed, to value [" & Target.Value & "]." & vbCrLf & "Workbook path:" & xFolderPath
        With xMailItem
            .To = "another.email@email.com"
            .Subject = "Subject for xRg02"
            .Body = xMailBody
            .Display
        End With
    End If
    '---------------------------------
        Set xRg01 = Nothing
        Set xRgSel01 = Nothing
        Set xRg02 = Nothing
        Set xRgSel02 = Nothing
        Set xOutApp = Nothing
        Set xMailItem = Nothing
End Sub