Перейти до основного матеріалу

Як автоматично надсилати електронну пошту на основі значення комірки в Excel?

Припустимо, ви хочете надіслати електронне повідомлення через Outlook певному одержувачу на основі вказаного значення комірки в Excel. Наприклад, коли значення комірки D7 на аркуші перевищує 200, електронна пошта створюється автоматично. Ця стаття представляє метод VBA для швидкого вирішення цієї проблеми.

Автоматично надсилати повідомлення електронної пошти на основі значення комірки з кодом VBA


Автоматично надсилати повідомлення електронної пошти на основі значення комірки з кодом VBA

Будь ласка, виконайте наступні дії, щоб надіслати електронне повідомлення на основі значення комірки в Excel.

1. На робочому аркуші вам потрібно надіслати електронне повідомлення на основі його значення комірки (тут написано клітинку D7), клацніть правою кнопкою миші вкладку аркуша та виберіть Переглянути код з контекстного меню. Дивіться знімок екрана:

2. У спливаючому Microsoft Visual Basic для додатків вікно, скопіюйте та вставте наведений нижче код VBA у вікно коду аркуша.

Код VBA: надсилання електронної пошти через Outlook на основі значення комірки в Excel

Dim xRg As Range
'Update by Extendoffice 2018/3/7
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
  Set xRg = Intersect(Range("D7"), Target)
    If xRg Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) And Target.Value > 200 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

примітки:

1). У коді VBA, D7 та значення> 200 - це значення комірки та значення комірки, за якими ви будете надсилати повідомлення електронною поштою.
2). Будь ласка, змініть текст електронної пошти, як вам потрібно xMailBody рядок у коді.
3). Замініть адресу електронної пошти на адресу електронної пошти одержувача в рядку .To = "Адреса електронної пошти".
4). І вкажіть одержувачів копії та прихованої копії, які вам потрібні .CC = "" та Прихована копія = "" розділи.
5). Нарешті змініть тему електронного листа в рядку .Subject = "відправити тестом значення комірки".

3 Натисніть кнопку інший + Q клавіші разом, щоб закрити Microsoft Visual Basic для додатків вікна.

Відтепер, коли значення, яке ви вводите в комірку D7, перевищує 200, електронна пошта із зазначеними одержувачами та тілом буде автоматично створюватися в Outlook. Ви можете натиснути Відправити , щоб надіслати цей електронний лист. Дивіться знімок екрана:

примітки:

1. Код VBA працює лише тоді, коли ви використовуєте Outlook як програму електронної пошти.

2. Якщо введені дані в комірці D7 є текстовим значенням, також з’явиться вікно електронної пошти.


Легко надсилайте електронну пошту через Outlook на основі полів створеного списку розсилки в Excel:

Команда Надіслати електронні листи корисність Kutools для Excel допомагає користувачам надсилати електронну пошту через Outlook на основі створеного списку розсилки в Excel.
Завантажте та спробуйте зараз! (30 днів безкоштовно)


Статті по темі:

Найкращі інструменти продуктивності офісу

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

Покращуйте свої навички Excel за допомогою Kutools для Excel і відчуйте ефективність, як ніколи раніше. Kutools для Excel пропонує понад 300 додаткових функцій для підвищення продуктивності та економії часу.  Натисніть тут, щоб отримати функцію, яка вам найбільше потрібна...

Опис


Вкладка Office Передає інтерфейс із вкладками в Office і значно полегшує вашу роботу

  • Увімкніть редагування та читання на вкладках у Word, Excel, PowerPoint, Publisher, Access, Visio та Project.
  • Відкривайте та створюйте кілька документів на нових вкладках того самого вікна, а не в нових вікнах.
  • Збільшує вашу продуктивність на 50% та зменшує сотні клацань миші для вас щодня!
Comments (318)
Rated 5 out of 5 · 1 ratings
This comment was minimized by the moderator on the site
Hello cristal, i need u help, im trying to use this code in a board, so i need that when for example E2 < D2 send a message with the information in C2, and this whit E3,D3,C3........ E4,D4,C4 etc.
This comment was minimized by the moderator on the site
Hi Ernesto,

The following VBA code may help. Please give it a try. Thank you.
Note: If a change is detected and the new value in an "E" row cell is less than its corresponding "D" row cell, it triggers the Mail_small_Text_Outlook subroutine. The content from the corresponding "C" row cell is passed into this subroutine and included in the email body.

Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by extendoffice 20230315
    Dim xRg As Range
    Dim cell As Range

    ' Only trigger for changes in column E
    Set xRg = Intersect(Me.Range("E:E"), Target)

    If Not xRg Is Nothing Then
        Application.EnableEvents = False ' Prevent further event triggers
        On Error GoTo Finalize ' Ensure events are re-enabled in case of error

        For Each cell In xRg
            ' Check if the cell in column E is less than the corresponding cell in column D
            If IsNumeric(cell.Value) And IsNumeric(cell.Offset(0, -1).Value) Then
                If cell.Value < cell.Offset(0, -1).Value Then
                    ' Call the mail subroutine, passing the content of the corresponding cell in column C
                    Call Mail_small_Text_Outlook(cell.Offset(0, -2).Value)
                End If
            End If
        Next cell

Finalize:
        Application.EnableEvents = True ' Re-enable events
        On Error GoTo 0 ' Clear error handling
    End If
End Sub

Sub Mail_small_Text_Outlook(ByVal mailContent As String)
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String

    ' Create the Outlook objects
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)

    ' Customize your email body with the content from column C
    xMailBody = "Hi there" & vbNewLine & vbNewLine & mailContent

    ' Customize the email details
    With xOutMail
        .To = "Email Address" ' Add your recipient here
        .CC = ""
        .BCC = ""
        .Subject = "Send by cell value test"
        .Body = xMailBody
        .Display   ' or use .Send to send the email directly
    End With

    ' Cleanup
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub
This comment was minimized by the moderator on the site
Dear, the code works perfectly, but I am still looking to expand it a bit for my project. I am creating a project dashboard where I track the progress of the projects. The end time of the project will then be listed in row G:G and if, for example, he still has 2 weeks before the project must be completed, he must send an email to the project owner who is responsible there, this project owner will then be in, for example, row "I" but each project is placed in a new column and therefore always has a different project owner. How can I process this so that VBA automatically sends me an email to the owner in I7 when the date is reached in BV G7?
And with G8 then send to the owner who is in I8? And so on of course.
Hopefully you can help me.
This comment was minimized by the moderator on the site
Hi Crystal,

This is great. Thank you! Not sure if you're still monitoring this I'm but wondering if you could advise on how to make some modifications to this code. I was able to tweak it to look at a range of cells rather than just a specific cell like in your original example (In my case D4:D41) but what if I want to look for changes made above a certain value in multiple columns? In my case I'd like to look for values >8 in D4:D41 as well as >13 in E4:E41. Also, is there a way to hold off on sending the email until multiple changes have been made instead of immediately after a cell in Column D (or E) is raised above the threshold? I know that by using the 'Developer' tab on the ribbon I can create a "Send Email" button but what tweaks to the code would need to be made so that it doesn't send until that button is clicked?

As a cherry on top, is there a way to call out the corresponding row data from column A in the body of the email? The sheet I'm working with has various room numbers in Column A and target values in Columns D & E. Is there a way to structure it so that if the value in, say, D11 goes above the threshold the email will say "Room # (A11)" needs attention and if E25 goes above its threshold the email will say Room # (E25) needs attention? If that makes sense
This comment was minimized by the moderator on the site
Hi, i have created and excel sheet that uses dates of the year ( todays date to next years expiry date ) the cell i have crated is a column consisting of 60+ candidates. The cell changes value until it reaches the expire date. I would like to use this column dates to trigger an automated email with an attachment of the excel sheet when the cell value reaches a certain amount before the expiry date.
I want to use this as an alert so that i can see which person document will expire.

Please help I've been struggling for a long while...

Thank you!!
This comment was minimized by the moderator on the site
Hi Andries,

Sorry I don't quite understand your question. Would you mind providing a screenshot of your data? Sorry for the inconvenience.
This comment was minimized by the moderator on the site
Hello, I set up the VBA to send an automatic email. Now, when a row with columns A, B, C, D, E, F, G, H, I, J, K, L, M, N is filled in, an email is automatically created and sent shall be. As an example, line 10 has now been filled in from A to N, as soon as this has happened this data should be sent in the email.
This should then be possible up to line 5000.
Can you help me with the problem?
This comment was minimized by the moderator on the site
Hi Michael Schlegel,

To modify the VBA code to automatically create an email when columns A to N in a row are filled out, follow these steps:
In the Worksheet_Change event, monitor the range A:N up to the 5000th row.
Check if all cells in the columns A to N of the changed row contain values.
If all cells in that row have values, trigger the email displaying function.


Private Sub Worksheet_Change(ByVal Target As Range)
'Updated by Extendoffice 20230817
    Dim EntireRow As Range
    Dim IsRowFilled As Boolean
    Dim i As Integer
    
    ' If multiple cells are changed simultaneously, exit
    If Target.Cells.CountLarge > 1 Then Exit Sub

    ' Only monitor the range A10:N5000
    If Not Intersect(Target, Range("A10:N5000")) Is Nothing Then
        ' Check if the entire row from A to N has values
        Set EntireRow = Range("A" & Target.Row & ":N" & Target.Row)
        IsRowFilled = True
        For Each cell In EntireRow
            If IsEmpty(cell.Value) Then
                IsRowFilled = False
                Exit For
            End If
        Next cell
        ' If the row is filled, send the email
        If IsRowFilled Then
            Call Mail_small_Text_Outlook(EntireRow)
        End If
    End If
End Sub

Sub Mail_small_Text_Outlook(RowData As Range)
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    
    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)

    ' Modify this line to format the email body as per your requirements
    xMailBody = "The following data has been entered:" & vbNewLine & Join(Application.Transpose(Application.Transpose(RowData.Value)), " ")

    On Error Resume Next
    With xOutMail
        .To = "Email Address"
        .CC = ""
        .BCC = ""
        .Subject = "New row filled out in Excel"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    
    Set xOutMail = Nothing
    Set xOutApp = Nothing
End Sub
This comment was minimized by the moderator on the site
Hi

Thank you so much for posting this VBA Code and instructions. Your code is most definitely continuing to help us rookies! Thank you 🥰! When I found it I felt like I'd won in the Excel VBA game. However, I am stuck on something so I'm hoping you can help. If not, please kindly point me in the right direction. I'm new to VBA, self-taught as much as possible, and only have very basic understanding of most of the commands.

Your code has helped me answer the question of "how to I send to an email address without having to manually enter the address in the code". But, now I'm struggling with "how to route through a list of addresses based on a cell condition". Meaning, I have a protected form with 28 data elements, 21 lines of data, and 5 approvers must approve the data before any action can be taken (data added to SAP). Signature lines have been added to the form for electronic approvals (was initially trying to use the Signature line email addresses but failed to find help on that issue).

Since I was not able to find how to use the Signature line email addresses, I created an email table with email addresses in the range M37:M42 and a Sent indicator in the range O37:O42.

Workflow: once the Originator of the form has completed entering the data, he/she clicks the "Send to Next Approver" button. The code for the button is to loop through checking that M & target row is not blank, check that the Sent indicator in O & target row is blank, then generate an email to the approver and set Sent indicator for that row to "X". The Originator (M37) will be the last to receive a final email showing all approvals. At the end of routing, all Sent indicator fields should have an "X" and the form is digitally signed and protected.

I'm getting a compile error : "Procedure declaration does not match description of event or procedure having the same name". I think it is something very simple look right at me, but I cannot see to find it. Thank you in advance.

Here's my code:

Dim xRg As Range
Private Sub CommandButton1_Click(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("O38:O42"), Target)
If xRg Is Nothing Then Exit Sub
If Target.Value = " " Then
Call Mail_small_Text_Outlook(Target)
Set Target.Value = "X"
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xRgTo As Range
Dim xOutlookObj As Object
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next

Set xRgTo = Application.Range("M" & Target.Row)
If xRgTo Is Nothing Then Exit Sub

ThisWorkbook.Worksheets("List Form").Unprotect ("9999")
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)

xMailBody = "Your review/approval is needed on a Material Master form." & vbNewLine & vbNewLine & _
"Click the hyperlink or copy/paste the file name in a browser to open form." & vbNewLine & vbNewLine & _
Range("BW1") & vbNewLine & _
" "
On Error Resume Next
With xOutMail
.To = xRgTo
' .CC = ""
' .BCC = ""
.Subject = "Material Master / BOM Review & Approval"
.Body = xMailBody
' .Attachments.Add ActiveWorkbook.FullName
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
ActiveSheet.Protect ("9999"), DrawingObjects:=False, Contents:=True, Scenarios:= _
True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowInsertingHyperlinks:=True, AllowSorting:=True, AllowFiltering:=True
' ThisWorkbook.Worksheets("List Form").Protect ("9999")
End Sub
This comment was minimized by the moderator on the site
Hi

Thank you so much for posting this VBA Code and instructions. Your code is most definitely continuing to help us rookies! Thank you 🥰! When I found it I felt like I'd won in the Excel VBA game. However, I am stuck on something so I'm hoping you can help. If not, please kindly point me in the right direction. I'm new to VBA, self-taught as much as possible, and only have very basic understanding of most of the commands.

Your code has helped me answer the question of "how to I send to an email address without having to manually enter the address in the code". But, now I'm struggling with "how to route through a list of addresses based on a cell condition". Meaning, I have a protected form with 28 data elements, 21 lines of data, and 5 approvers must approve the data before any action can be taken (data added to SAP). Signature lines have been added to the form for electronic approvals (was initially trying to use the Signature line email addresses but failed to find help on that issue).

Since I was not able to find how to use the Signature line email addresses, I created an email table with email addresses in the range M37:M42 and a Sent indicator in the range O37:O42.

Workflow: once the Originator of the form has completed entering the data, he/she clicks the "Send to Next Approver" button. The code for the button is to loop through checking that M & target row is not blank, check that the Sent indicator in O & target row is blank, then generate an email to the approver and set Sent indicator for that row to "X". The Originator (M37) will be the last to receive a final email showing all approvals. At the end of routing, all Sent indicator fields should have an "X" and the form is digitally signed and protected.

I'm getting a compile error : "Procedure declaration does not match description of event or procedure having the same name". I think it is something very simple look right at me, but I cannot see to find it. Thank you in advance.

Here's my code:

Dim xRg As Range
Private Sub CommandButton1_Click(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Range("O38:O42"), Target)
If xRg Is Nothing Then Exit Sub
If Target.Value = " " Then
Call Mail_small_Text_Outlook(Target)
Set Target.Value = "X"
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xRgTo As Range
Dim xOutlookObj As Object
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
On Error Resume Next

Set xRgTo = Application.Range("M" & Target.Row)
If xRgTo Is Nothing Then Exit Sub

ThisWorkbook.Worksheets("List Form").Unprotect ("9999")
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)

xMailBody = "Your review/approval is needed on a Material Master form." & vbNewLine & vbNewLine & _
"Click the hyperlink or copy/paste the file name in a browser to open form." & vbNewLine & vbNewLine & _
Range("BW1") & vbNewLine & _
" "
On Error Resume Next
With xOutMail
.To = xRgTo
' .CC = ""
' .BCC = ""
.Subject = "Material Master / BOM Review & Approval"
.Body = xMailBody
' .Attachments.Add ActiveWorkbook.FullName
.Display 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
ActiveSheet.Protect ("9999"), DrawingObjects:=False, Contents:=True, Scenarios:= _
True, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowInsertingHyperlinks:=True, AllowSorting:=True, AllowFiltering:=True
' ThisWorkbook.Worksheets("List Form").Protect ("9999")
End Sub
This comment was minimized by the moderator on the site
Wie schreibe ich den Code um, wenn je nachdem welche Zelle ausgefüllt wird eine Mail an eine bestimmte Person gehen soll.

Beispielsweise wird Zelle A1 ausgefüllt, dann geht automatisch ein Mail Fenster auf mit Mail Adresse von Person A.
Wenn Zelle B1 ausgefüllt wird, dann geht automatisch ein Mail Fenster auf mit Mail Adresse von Person B
... etc.

Ich habe es mit der Funktion Case versucht, jedoch leider nicht geschafft.
Besten Dank für die Rückmeldung.
This comment was minimized by the moderator on the site
Dear

code run when insect value in D7 but can't run when D7 = result ( X+Y)
How to ?
Thanks your
This comment was minimized by the moderator on the site
Hi I am looking for a code that when a cell changes YELLOW, I want an email to send automatically to that person and when the cell changes RED another e-mail to be sent to them.

The cells contain expiry dates of mandatory training and are:
- GREEN when in date,
- YELLOW when they have 29 days before they are out of date AND
- RED when they are a day over the date that their training expires.

The e-mails are to prompt them to book onto a course when they are YELLOW (almost out of date) and to input there new expiry date when they get an email when it turns RED.

Hope that all makes sense.

Formula for it to turn green: GREATER THAN =NOW()+30
Yellow: BETWEEN =NOW() =NOW()+29
Red: LESS THAN =NOW()-1

Thank you in advance, Alyssa
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