Ugrás a tartalomra

Hogyan lehet e-mailt küldeni, ha egy bizonyos cellát módosítanak az Excelben?

Ez a cikk az Outlookon keresztüli e-mail küldéséről szól, amikor egy bizonyos tartományban lévő cellát módosítanak az Excelben.

E-mail küldése, ha egy bizonyos tartományban lévő cellát VBA kóddal módosítottak


E-mail küldése, ha egy bizonyos tartományban lévő cellát VBA kóddal módosítottak

Ha automatikusan létre kell hoznia egy új e-mailt aktív munkafüzet csatolásával, amikor az A2:E11 tartomány celláját módosítják egy bizonyos munkalapon, a következő VBA-kód segíthet.

1. Abban a munkalapban, amelyet e-mailt kell küldenie a módosított cellája alapján egy bizonyos tartományban, kattintson a jobb gombbal a lap fülre, majd kattintson a Kód megtekintése a helyi menüből. Lásd a képernyőképet:

2. A felbukkanóban Microsoft Visual Basic for Applications ablakba, kérjük, másolja és illessze be a VBA kód alatt a Kód ablakba.

VBA kód: E-mail küldése, ha a megadott tartomány cellája módosul az Excel programban

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

Megjegyzések:

1). A kódban A2: E11 az a tartomány, amely alapján e-mailt fog küldeni.
2). Kérjük, módosítsa az e-mail törzsét, amire szüksége van xMailBody sor a kódban.
3). Helyettesíteni a E-mail címe a címzett e-mail címével a sorban .To = "E-mail cím".
4). Változtassa meg az e-mail tárgyát sorban .Subject = "Munkalap módosítva a" & ThisWorkbook.FullName fájlban.

3. megnyomni a más + Q gombok egyszerre a Microsoft Visual Basic for Applications ablak.

Ezentúl az A2: E11 tartomány bármely cellája módosul, új e-mailt hozunk létre, a csatolt frissített munkafüzettel együtt. És az összes megadott mező, mint például a tárgy, a címzett és az e-mail törzse, megjelenik az e-mailben. Kérjük, küldje el az e-mailt.

Megjegyzések: A VBA-kód csak akkor működik, ha az Outlookot használja levelezőprogramként.


Kapcsolódó cikkek:

A legjobb irodai hatékonyságnövelő eszközök

🤖 Kutools AI Aide: Forradalmasítsa az adatelemzést a következők alapján: Intelligens végrehajtás   |  Kód létrehozása  |  Hozzon létre egyéni képleteket  |  Adatok elemzése és diagramok létrehozása  |  A Kutools funkciók meghívása...
Népszerű szolgáltatások: Ismétlődések keresése, kiemelése vagy azonosítása   |  Üres sorok törlése   |  Oszlopok vagy cellák kombinálása adatvesztés nélkül   |   Kerek Formula nélkül ...
Szuper keresés: Több kritérium VLookup    Többértékű VLookup  |   VLookup több munkalapon   |   Fuzzy Lookup ....
Speciális legördülő lista: Gyors legördülő lista létrehozása   |  Függő legördülő lista   |  Többszörösen válassza ki a legördülő listát ....
Oszlopkezelő: Adjon meg egy adott számú oszlopot  |  Oszlopok mozgatása  |  Kapcsolja be a Rejtett oszlopok láthatósági állapotát  |  Tartományok és oszlopok összehasonlítása ...
Kiemelt funkciók: Rács fókusz   |  Design nézet   |   Nagy Formula bár    Munkafüzet és lapkezelő   |  Erőforrás-könyvtár (Auto szöveg)   |  Dátumválasztó   |  Kombinálja a munkalapokat   |  Cellák titkosítása/dekódolása    E-mailek küldése listánként   |  Szuper szűrő   |   Speciális szűrő (félkövér/dőlt/áthúzott szűrés...) ...
A 15 legjobb eszközkészlet12 szöveg Eszközök (Szöveg hozzáadása, Karakterek eltávolítása,...)   |   50 + Táblázatos Típusai (Gantt-diagram,...)   |   40+ Praktikus képletek (Számolja ki az életkort a születésnap alapján,...)   |   19 beszúrás Eszközök (Helyezze be a QR-kódot, Kép beszúrása az útvonalból,...)   |   12 Átalakítás Eszközök (Számok szavakig, Valuta átváltás,...)   |   7 Egyesítés és felosztás Eszközök (Haladó kombinált sorok, Hasított sejtek,...)   |   ... és több

Töltsd fel Excel-készségeidet a Kutools for Excel segítségével, és tapasztald meg a még soha nem látott hatékonyságot. A Kutools for Excel több mint 300 speciális funkciót kínál a termelékenység fokozásához és az időmegtakarításhoz.  Kattintson ide, hogy megszerezze a leginkább szükséges funkciót...

Leírás


Az Office lap füles felületet hoz az Office-ba, és sokkal könnyebbé teszi a munkáját

  • Füles szerkesztés és olvasás engedélyezése Wordben, Excelben és PowerPointban, Publisher, Access, Visio és Project.
  • Több dokumentum megnyitása és létrehozása ugyanazon ablak új lapjain, mint új ablakokban.
  • 50% -kal növeli a termelékenységet, és naponta több száz kattintással csökkenti az egér kattintását!
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