基于 Excel 范围更新/更改的自动电子邮件

Question

我有一个 excel 宏，可以在单元格更新时自动发送电子邮件。我希望能够根据单元格更新将其发送到两个不同的邮箱。例如，如果更新了单元格 D5：D10，则电子邮件将发送到邮箱 1，如果更新了单元格 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 = "[e-mail]"
.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 = "[e-mail]"
.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 = "[e-mail]"
.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