Přejít k hlavnímu obsahu

Jak odeslat e-mail, pokud je určitá buňka upravena v aplikaci Excel?

Tento článek pojednává o odeslání e-mailu přes Outlook, když je v Excelu upravena buňka v určitém rozsahu.

Pošlete e-mail, pokud je buňka v určitém rozsahu upravena kódem VBA


Pošlete e-mail, pokud je buňka v určitém rozsahu upravena kódem VBA

Pokud potřebujete automaticky vytvořit nový e-mail s připojeným aktivním sešitem, když je v určitém listu upravena buňka v rozsahu A2:E11, může vám pomoci následující kód VBA.

1. V listu, který potřebujete odeslat e-mail na základě jeho upravené buňky v určitém rozsahu, klikněte pravým tlačítkem na kartu listu a poté klikněte na Zobrazit kód z kontextové nabídky. Viz snímek obrazovky:

2. Ve vyskakovacím okně Microsoft Visual Basic pro aplikace zkopírujte a vložte pod kód VBA do okna Kód.

Kód VBA: Odeslat e-mail, pokud je buňka ve specifikovaném rozsahu upravena v aplikaci 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

Poznámky:

1). V kódu A2: E11 je rozsah, na kterém budete posílat e-maily.
2). Změňte prosím text e-mailu, jak potřebujete xMailBody řádek v kódu.
3). Nahradit Emailová adresa s e-mailovou adresou příjemce v řádku .To = "E-mailová adresa".
4). Změňte předmět e-mailu v řádku .Subject = "List upraven v" & ThisWorkbook.FullName.

3. zmáčkni Další + Q současně zavřete Microsoft Visual Basic pro aplikace okno.

Od této chvíle se upraví libovolná buňka v rozsahu A2: E11, vytvoří se nový e-mail s připojeným aktualizovaným sešitem. A všechna zadaná pole, jako je předmět, příjemce a tělo e-mailu, budou uvedena v e-mailu. Zašlete prosím e-mail.

Poznámka: Kód VBA funguje pouze v případě, že jako e-mailový program používáte Outlook.


Související články:

Nejlepší nástroje pro produktivitu v kanceláři

Populární funkce: Najít, zvýraznit nebo identifikovat duplikáty   |  Odstranit prázdné řádky   |  Kombinujte sloupce nebo buňky bez ztráty dat   |   Kolo bez vzorce ...
Super vyhledávání: Více kritérií VLookup    VLookup s více hodnotami  |   VLookup na více listech   |   Fuzzy vyhledávání ....
Pokročilý rozevírací seznam: Rychle vytvořte rozevírací seznam   |  Závislý rozbalovací seznam   |  Vícenásobný výběr rozevíracího seznamu ....
Správce sloupců: Přidejte konkrétní počet sloupců  |  Přesunout sloupce  |  Přepnout stav viditelnosti skrytých sloupců  |  Porovnejte rozsahy a sloupce ...
Doporučené funkce: Zaměření mřížky   |  Návrhové zobrazení   |   Velký Formula Bar    Správce sešitů a listů   |  Knihovna zdrojů (Automatický text)   |  Výběr data   |  Zkombinujte pracovní listy   |  Šifrovat/dešifrovat buňky    Odesílat e-maily podle seznamu   |  Super filtr   |   Speciální filtr (filtr tučné/kurzíva/přeškrtnuté...) ...
Top 15 sad nástrojů12 Text Tools (doplnit text, Odebrat znaky, ...)   |   50+ Graf Typ nemovitosti (Ganttův diagram, ...)   |   40+ Praktické Vzorce (Vypočítejte věk na základě narozenin, ...)   |   19 Vložení Tools (Vložte QR kód, Vložit obrázek z cesty, ...)   |   12 Konverze Tools (Čísla na slova, Přepočet měny, ...)   |   7 Sloučit a rozdělit Tools (Pokročilé kombinování řádků, Rozdělit buňky, ...)   |   ... a více

Rozšiřte své dovednosti Excel pomocí Kutools pro Excel a zažijte efektivitu jako nikdy předtím. Kutools for Excel nabízí více než 300 pokročilých funkcí pro zvýšení produktivity a úsporu času.  Kliknutím sem získáte funkci, kterou nejvíce potřebujete...

karta kte 201905


Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50%a snižuje stovky kliknutí myší každý den!
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