Автоматическая электронная почта на основе обновлений / изменений диапазона Excel

Question

У меня есть этот макрос Excel, который автоматически отправляет электронное письмо при обновлении ячейки. Я хочу иметь возможность отправить его в два разных почтовых ящика на основе обновления ячейки. Например, если ячейка D5: D10 обновлена, электронная почта отправляется на mailbox1, если ячейка D12: 20 обновлена, электронная почта отправляется на почтовый ящик 2. Я также хочу включить путь к папке в теле сообщения.

Это то, что я до сих пор:

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

Вы можете получить простое решение, просто разделив наблюдаемые диапазоны на два (или более). Я не уверен, почему вы сохраняете рабочую книгу после изменения, но я помещаю ее в блок If, поэтому рабочая книга сохраняется только тогда, когда изменение находится в пределах наблюдаемых диапазонов.

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