Прескочи на основното съдържание

Как да изпратите имейл, ако определена клетка е променена в Excel?

Автор: Силувия Последна промяна: 2022-05-20

Тази статия говори за изпращане на имейл през Outlook, когато клетка в определен диапазон е променена в Excel.

Изпращане на имейл, ако клетка в определен диапазон е променена с VBA код


Изпращане на имейл, ако клетка в определен диапазон е променена с VBA код

Ако трябва автоматично да създадете нов имейл с прикачена активна работна книга, когато клетка в диапазон A2:E11 е променена в определен работен лист, следният VBA код може да ви помогне.

1. В работния лист, на който трябва да изпратите имейл въз основа на неговата модифицирана клетка в определен диапазон, щракнете с десния бутон върху раздела на листа и след това щракнете върху Преглед на кода от контекстното меню. Вижте екранна снимка:

2. При изскачане Microsoft Visual Basic за приложения прозорец, моля, копирайте и поставете под кода на VBA в прозореца на кода.

VBA код: Изпратете имейл, ако клетка в определен диапазон е променена в Excel

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2017/9/12
    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("A2:E11")
    Set xRgSel = Intersect(Target, xRg)
    ActiveWorkbook.Save
    If Not xRgSel Is Nothing Then
        Set xOutApp = CreateObject("Outlook.Application")
        Set xMailItem = xOutApp.CreateItem(0)
        xMailBody = "Cell(s) " & xRgSel.Address(False, False) & _
            " in the worksheet '" & Me.Name & "' were modified on " & _
            Format$(Now, "mm/dd/yyyy") & " at " & Format$(Now, "hh:mm:ss") & _
            " by " & Environ$("username") & "."

        With xMailItem
            .To = "Email Address"
            .Subject = "Worksheet modified in " & ThisWorkbook.FullName
            .Body = xMailBody
            .Attachments.Add (ThisWorkbook.FullName)
            .Display
        End With
        Set xRgSel = Nothing
        Set xOutApp = Nothing
        Set xMailItem = Nothing
    End If
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

бележки:

1). В кода, A2:E11 е диапазонът, въз основа на който ще изпратите имейл.
2). Моля, променете тялото на имейла, както е необходимо xMailBody ред в кода.
3). Сменете Имейл Адрес с имейл адреса на получателя в ред .To = "Имейл адрес".
4). Променете темата на имейла в ред .Subject = "Работен лист, модифициран в " & ThisWorkbook.FullName.

3. Натисни Друг + Q клавиши едновременно, за да затворите Microsoft Visual Basic за приложения прозорец.

Отсега нататък всяка клетка в диапазон A2:E11 се променя, ще бъде създаден нов имейл с прикачената актуализирана работна книга. И всички посочени полета като тема, получател и текст на имейл ще бъдат изброени в имейла. Моля, изпратете имейла.

Забележка: VBA кодът работи само ако използвате Outlook като своя имейл програма.


Още по темата:

Най-добрите инструменти за продуктивност в офиса

🤖 Kutools AI помощник: Революционизирайте анализа на данни въз основа на: Интелигентно изпълнение   |  Генериране на код  |  Създаване на персонализирани формули  |  Анализирайте данни и генерирайте диаграми  |  Извикване на функциите на Kutools...
Популярни функции: Намерете, маркирайте или идентифицирайте дубликати   |  Изтриване на празни редове   |  Комбинирайте колони или клетки без загуба на данни   |   Кръг без формула ...
Супер търсене: VLookup с множество критерии    VLookup с множество стойности  |   VLookup в няколко листа   |   Размито търсене ....
Разширен падащ списък: Бързо създаване на падащ списък   |  Зависим падащ списък   |  Падащ списък с множество избори ....
Мениджър на колони: Добавете конкретен брой колони  |  Преместване на колони  |  Превключване на състоянието на видимост на скритите колони  |  Сравнете диапазони и колони ...
Препоръчани функции: Мрежов фокус   |  Изглед на дизайна   |   Голям формула бар    Мениджър на работни книги и листове   |  Библиотека с ресурси (Автоматичен текст)   |  Избор на дата   |  Комбинирайте работни листове   |  Шифроване/декриптиране на клетки    Изпращайте имейли по списък   |  Супер филтър   |   Специален филтър (филтър получер/курсив/зачертано...) ...
Топ 15 комплекта инструменти12 Текст Инструменти (добавяне на текст, Премахване на символи, ...)   |   50 + Графика Видове (диаграма на Гант, ...)   |   40+ Практичен формули (Изчислете възрастта въз основа на рождения ден, ...)   |   19 вмъкване Инструменти (Въведете QR код, Вмъкване на картина от пътя, ...)   |   12 Конверсия Инструменти (Числа към думи, Валутен обмен, ...)   |   7 Обединяване и разделяне Инструменти (Разширено комбиниране на редове, Разделени клетки, ...)   |   ... и още

Усъвършенствайте уменията си за Excel с Kutools за Excel и изпитайте ефективност, както никога досега. Kutools за Excel предлага над 300 разширени функции за повишаване на производителността и спестяване на време.  Щракнете тук, за да получите функцията, от която се нуждаете най-много...

Описание


Раздел Office Внася интерфейс с раздели в Office и прави работата ви много по-лесна

  • Разрешете редактиране и четене с раздели в Word, Excel, PowerPoint, Publisher, Access, Visio и Project.
  • Отваряйте и създавайте множество документи в нови раздели на един и същ прозорец, а не в нови прозорци.
  • Увеличава вашата производителност с 50% и намалява стотици кликвания на мишката за вас всеки ден!
Comments (41)
Rated 5 out of 5 · 1 ratings
This comment was minimized by the moderator on the site
Hi, Please I want the above code with two little changes

1.It should work at workbook level if there is any change in entire workbook or cell it should send mail
2.Code should trigger mail after cell change but on workbook save
This comment was minimized by the moderator on the site
Hi, Please I want the above code with two little changes

1.It should work at workbook level if there is any change in entire workbook or cell it should send mail
2.Code should trigger mail not on cell change but on workbook save
This comment was minimized by the moderator on the site
Hi Ajay_2510,
To achieve your two requirements:

1. Have the event trigger for changes on any worksheet within the workbook.
2. Trigger the event only when saving the workbook.

You'll need to move your code from the Worksheet_Change event in a specific worksheet to the Workbook_BeforeSave event in the ThisWorkbook module.
https://www.extendoffice.com/images/stories/comments/comment-picture-zxm/thisworkbook.png?1692238842

Here's the modified code:


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xMailBody As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set xOutApp = CreateObject("Outlook.Application")
    Set xMailItem = xOutApp.CreateItem(0)
    xMailBody = "The workbook '" & ThisWorkbook.FullName & _
                "' was modified on " & Format$(Now, "mm/dd/yyyy") & _
                " at " & Format$(Now, "hh:mm:ss") & " by " & Environ$("username") & "."

    With xMailItem
        .To = "Email Address"
        .Subject = "Workbook modified: " & ThisWorkbook.FullName
        .Body = xMailBody
        .Attachments.Add (ThisWorkbook.FullName)
        .Display   ' Or use .Send to send the email automatically
    End With

    Set xOutApp = Nothing
    Set xMailItem = Nothing

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
This comment was minimized by the moderator on the site
Only 1 issue here ,Otherwise it works great.

1.It triggers mail also if someone opens workbook and saves it (Without making changes)

I want it to trigger mail if changes are made in workbook and saved only in that particular case.
if user is not making changes and just opening and saving the workbook the mail should not shoot.

Thanks for the help, I appreciate it
Rated 5 out of 5
This comment was minimized by the moderator on the site
Here's another question. If one cell changes, it sends a email. if 3 cells change, it sends 3 emails. How do you stop this so it only sends 1 email when the edits are done?
This comment was minimized by the moderator on the site
Hi Joe,
Supposing you specified the range as "A2:E11" in the code. How can I verify when the whole edits are done?
This comment was minimized by the moderator on the site
I would like to send the email to 5 people. What delineator is used between each email address?
This comment was minimized by the moderator on the site
Hi Joe,
Please use a semicolon to separate the email addresses.
This comment was minimized by the moderator on the site
Bonjour et merci pour ce tuto.
J'ai cependant une difficulté pour l'application de la plage de recherche.
Dans le code, j'ai demandé à vérifier la plage C2:C4.
Tout fonctionne bien si je modifie C2, C3 ou C4 uniquement. Cela fonctionne aussi si je modifie C2+C3+C4 ou C2+C3 ou C3+C4 mais cela ne fonctionne pas si j'ai un saut dans la plage. Par exemple, si je modifie C2 et C4 sans modifier C3.
Est-ce que quelqu'un pourrait m'aider pour m'indiquer où se trouve mon erreur ?
Merci d'avance.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220921
Dim xAddress As String
Dim xDRg, xRgSel, xRg As Range

xAddress = "C2:C4"
Set xDRg = Range(xAddress)
Set xRgSel = Intersect(Target, xDRg)
On Error GoTo Err1
If Not xRgSel Is Nothing Then
If ThisWorkbook.gChangeRange = "" Then
ThisWorkbook.gChangeRange = xRgSel.AddressLocal(False, False, xlA1, True, False)
Else
Set xRg = Range(ThisWorkbook.gChangeRange)
Set xRg = Application.Union(xRg, xRgSel)
ThisWorkbook.gChangeRange = xRg.AddressLocal(False, False, xlA1, True, False)
End If
End If
Exit Sub
Err1:
ThisWorkbook.gChangeRange = xRgSel.AddressLocal(False, False, xlA1, True, False)
End Sub


-----

Option Explicit
Public gChangeRange As String
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
'Updated by Extendoffice 20220921
Dim xRgSel, xRg As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xMailBody As String
'On Error Resume Next
On Error GoTo Err1
Set xRg = Range(gChangeRange)
If Not xRg Is Nothing Then
Set xOutApp = CreateObject("Outlook.Application")
Set xMailItem = xOutApp.CreateItem(0)
xMailBody = "Cher Jean-Marie, " & vbCrLf & vbCrLf & "Dans le fichier : " & ThisWorkbook.FullName & vbCrLf & "La plage de cellules a été modifiée :" & xRg.Address(False, False) & vbCrLf & vbCrLf & "Cordialement"
With xMailItem
.To = ""
.Subject = "Données modifiées " & ThisWorkbook.Name
.Body = xMailBody
.Attachments.Add (ThisWorkbook.FullName)
.Display
End With
Set xRgSel = Nothing
Set xOutApp = Nothing
Set xMailItem = Nothing
End If
Err1:
gChangeRange = ""
End Sub
This comment was minimized by the moderator on the site
I'm needing some help with triggering an email with a slight change. Instead of a numerical value or entering the information into the cell manually, cells in column B will change to 'Y' triggered from a formula in other cells in that row. The formula for column B is =IF([@[Quantity in Stock]]>[@[Reorder Level]],,"Y"), showing that the inventory is low in stock and needs a re-order. I need to trigger an automated email when a cell value changes in column B to 'Y', so I'm notified automatically via email of the low stock. I've tried everything I can think of in altering codes already provided, but nothing seems to work for me... please help!
This comment was minimized by the moderator on the site
Hi Kathryn F,
The following VBA code can help you solve the problem. Please give it a try. Thank you for your comment.
Dim xRg As Range
'Update by Extendoffice 20221019
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("B:B"), Target)
If xRg Is Nothing Then Exit Sub
If Target.Value = "Y" Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2"
On Error Resume Next
With xOutMail
.To = "Email Address"
.CC = ""
.BCC = ""
.Subject = "send by cell value test"
.Body = xMailBody
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub

Private Sub Worksheet_Calculate()
Dim xTarget As String
Dim xRg As Range
'Set xRg = Application.Range("B:B")
Set xRg = Intersect(Range("B:B"), Selection.EntireRow)
On Error GoTo Err01
If xRg.Value = "Y" Then
Call Mail_small_Text_Outlook
End If
Err01:
End Sub
This comment was minimized by the moderator on the site
Hallo zusammen,

der Code würde gut für mein Vorhaben passen, aber gibt es die Möglichkeit, dass er eine E-Mail beim speichern schreibt mit allen Zellen die geändert wurden? So wie es jetzt ist ,würde er jede geänderte Zelle einzeln senden. Dies ist dann problematisch wenn z.B. 10 Zellen angepasst werden was 10 E-Mails bedeuten würde. Und gibt es die Möglichkeit, die gesamte geänderte Zelle bei mir von A bis Y in einer E-Mail zu senden? Bisher haut der ja die Zellnummer in die E-Mail, wenn aber jemand anders Filtert wird er die Änderung nicht mehr finden.
This comment was minimized by the moderator on the site
Hi Esser123,
The following VBA codes can help. After modifying the cells in the specified range and save the workbook, an email will pop up to list all modified cells in the email body, and the workbook will be inserted as an attachment in the email as well. Please follow the following steps:
1. Open the worksheet that contains the cells you want to send emails based on, right click the sheet tab and click View Code from the right-click menu. Then copy the following code into the sheet(code) window.
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20220921
Dim xAddress As String
Dim xDRg, xRgSel, xRg As Range

xAddress = "A1:A8"
Set xDRg = Range(xAddress)
Set xRgSel = Intersect(Target, xDRg)
On Error GoTo Err1
If Not xRgSel Is Nothing Then
If ThisWorkbook.gChangeRange = "" Then
ThisWorkbook.gChangeRange = xRgSel.AddressLocal(False, False, xlA1, True, False)
Else
Set xRg = Range(ThisWorkbook.gChangeRange)
Set xRg = Application.Union(xRg, xRgSel)
ThisWorkbook.gChangeRange = xRg.AddressLocal(False, False, xlA1, True, False)
End If
End If
Exit Sub
Err1:
      ThisWorkbook.gChangeRange = xRgSel.AddressLocal(False, False, xlA1, True, False)
End Sub

2. In the Visual Basic editor, double click ThisWorkbook in the left pane, then copy the following VBA code to the ThisWorkbook(Code) window.
Option Explicit
Public gChangeRange As String
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
'Updated by Extendoffice 20220921
Dim xRgSel, xRg As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xMailBody As String
'On Error Resume Next
On Error GoTo Err1
Set xRg = Range(gChangeRange)
If Not xRg Is Nothing Then
   Set xOutApp = CreateObject("Outlook.Application")
        Set xMailItem = xOutApp.CreateItem(0)
        xMailBody = "Email Body: " & vbCrLf & "The following cells were modified:" & xRg.Address(False, False)
        With xMailItem
            .To = "Email Address"
            .Subject = "Worksheet modified in " & ThisWorkbook.FullName
            .Body = xMailBody
            .Attachments.Add (ThisWorkbook.FullName)
            .Display
        End With
        Set xRgSel = Nothing
        Set xOutApp = Nothing
        Set xMailItem = Nothing
End If
Err1:
gChangeRange = ""
End Sub
This comment was minimized by the moderator on the site
Hello, I have created a similar code but I would like to *** a condition where if a cell value is deleted that is will not send an email when it is save/closed. It will only send an email when a cell value has been entered. Do you know how to do this? This is my code:

CODE FOR AUTOMATIC EMAIL TO SOMEONE WHEN EXCEL WORKBOOK IS UPDATED

SHEET CODE:

Option Explicit 'Excel worksheet change event Range
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C3:D62")) Is Nothing Then
'Target.EntireRow.Interior.ColorIndex = 15
Range("XFD1048576").Value = 15
End If
If Not Intersect(Target, Range("I3:J21")) Is Nothing Then
'Target.EntireRow.Interior.ColorIndex = 15
Range("XFD1048576").Value = 15
End If
End Sub


WORKBOOK CODE:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Me.Saved = False Then Me.Save

Dim xOutApp As Object
Dim xMailItem As Object
Dim xName As String

If Range("XFD1048576").Value = 15 Then
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xMailItem = xOutApp.CreateItem(0)
xName = ActiveWorkbook.FullName
With xMailItem
.To = "email"
.CC = ""
.Subject = "message"
.Body = "message!"
.Attachments.*** xName
.Display
'.send
End With
End If
Set xMailItem = Nothing
Set xOutApp = Nothing



End Sub

Private Sub Workbook_Open()
Range("XFD1048576").Clear
End Sub
This comment was minimized by the moderator on the site
Thank you for the code, this code works when I enter the value and press enter. But in my case the cell is filling automatically with formula, and when the value is reached it doesn't open the email so the code do not works in this case. Thank you in advance!
This comment was minimized by the moderator on the site
Hi hakana,
The following VBA code can help you solve the problem. Please give it a try. Thank you for your feedback.

<div data-tag="code">Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 2022/04/15
Dim xRgSel As Range
Dim xOutApp As Object
Dim xMailItem As Object
Dim xMailBody As String
Dim xBoolean As Boolean
Dim xItsRG As Range
Dim xDDs As Range
Dim xDs As Range
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
xBoolean = False
Set xRg = Range("E2:E13")

Set xItsRG = Intersect(Target, xRg)
Set xDDs = Intersect(Target.DirectDependents, xRg)
Set xDs = Intersect(Target.Dependents, xRg)
If Not (xItsRG Is Nothing) Then
Set xRgSel = xItsRG
xBoolean = True
ElseIf Not (xDDs Is Nothing) Then
Set xRgSel = xDDs
xBoolean = True
ElseIf Not (xDs Is Nothing) Then
Set xRgSel = xDs
xBoolean = True
End If


ActiveWorkbook.Save
If xBoolean Then
Debug.Print xRgSel.Address


Set xOutApp = CreateObject("Outlook.Application")
Set xMailItem = xOutApp.CreateItem(0)
xMailBody = "Cell(s) " & xRgSel.Address(False, False) & _
" in the worksheet '" & Me.Name & "' were modified on " & _
Format$(Now, "mm/dd/yyyy") & " at " & Format$(Now, "hh:mm:ss") & _
" by " & Environ$("username") & "."

With xMailItem
.To = "Email Address"
.Subject = "Worksheet modified in " & ThisWorkbook.FullName
.Body = xMailBody
.Attachments.Add (ThisWorkbook.FullName)
.Display
End With
Set xRgSel = Nothing
Set xOutApp = Nothing
Set xMailItem = Nothing
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This comment was minimized by the moderator on the site
Is it possible to change this so it only displays the email if a cell in a range has been changed to say "Yes". Would like it to do nothing if it is any other value.
There are no comments posted here yet
Load More
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations