انتقل إلى المحتوى الرئيسي

كيفية إرسال بريد إلكتروني إذا تم الوفاء بتاريخ الاستحقاق في Excel؟

كما هو موضح في لقطة الشاشة أدناه ، إذا كان تاريخ الاستحقاق في العمود C أقل من أو يساوي 7 أيام (على سبيل المثال ، التاريخ الحالي هو 2017/9/13) ، يتم إرسال بريد إلكتروني إلى المستلم المحدد في العمود A و يتم عرض المحتوى المحدد في العمود B في نص البريد الإلكتروني. كيف يمكنك أن تفعل لتحقيق ذلك؟ توفر هذه المقالة رمز VBA لمساعدتك في إنجاز هذه المهمة.

أرسل بريدًا إلكترونيًا إذا تم استيفاء تاريخ الاستحقاق برمز VBA


أرسل بريدًا إلكترونيًا إذا تم استيفاء تاريخ الاستحقاق برمز VBA

يرجى القيام بما يلي لإرسال تذكير بالبريد الإلكتروني إذا تم الوفاء بتاريخ الاستحقاق في Excel.

1. اضغط على قديم + F11 مفاتيح في نفس الوقت لفتح ميكروسوفت فيسوال باسيك للتطبيقات نافذة.

2. في ال ميكروسوفت فيسوال باسيك للتطبيقات نافذة ، الرجاء الضغط إدراج > وحدة. ثم انسخ والصق رمز فبا أدناه في نافذة الوحدة النمطية.

كود فبا: أرسل بريدًا إلكترونيًا إذا كان تاريخ الاستحقاق مغلقًا في إكسيل

Public Sub CheckAndSendMail()
'Updated by Extendoffice 2018/11/22
    Dim xRgDate As Range
    Dim xRgSend As Range
    Dim xRgText As Range
    Dim xRgDone As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xLastRow As Long
    Dim vbCrLf As String
    Dim xMailBody As String
    Dim xRgDateVal As String
    Dim xRgSendVal As String
    Dim xMailSubject As String
    Dim i As Long
    On Error Resume Next
    Set xRgDate = Application.InputBox("Please select the due date column:", "KuTools For Excel", , , , , , 8)
    If xRgDate Is Nothing Then Exit Sub
    Set xRgSend = Application.InputBox("Please select the recipients?email column:", "KuTools For Excel", , , , , , 8)
    If xRgSend Is Nothing Then Exit Sub
    Set xRgText = Application.InputBox("Select the column with reminded content in your email:", "KuTools For Excel", , , , , , 8)
    If xRgText Is Nothing Then Exit Sub
    xLastRow = xRgDate.Rows.count
    Set xRgDate = xRgDate(1)
    Set xRgSend = xRgSend(1)
    Set xRgText = xRgText(1)
    Set xOutApp = CreateObject("Outlook.Application")
    For i = 1 To xLastRow
        xRgDateVal = ""
        xRgDateVal = xRgDate.Offset(i - 1).Value
        If xRgDateVal <> "" Then
        If CDate(xRgDateVal) - Date <= 7 And CDate(xRgDateVal) - Date > 0 Then
            xRgSendVal = xRgSend.Offset(i - 1).Value
            xMailSubject = xRgText.Offset(i - 1).Value & " on " & xRgDateVal
            vbCrLf = "<br><br>"
            xMailBody = "<HTML><BODY>"
            xMailBody = xMailBody & "Dear " & xRgSendVal & vbCrLf
            xMailBody = xMailBody & "Text : " & xRgText.Offset(i - 1).Value & vbCrLf
            xMailBody = xMailBody & "</BODY></HTML>"
            Set xMailItem = xOutApp.CreateItem(0)
            With xMailItem
                .Subject = xMailSubject
                .To = xRgSendVal
                .HTMLBody = xMailBody
                .Display
                '.Send
            End With
            Set xMailItem = Nothing
        End If
    End If
    Next
    Set xOutApp = Nothing
End Sub

ملاحظة: الخط إذا كان CDate (xRgDateVal) - التاريخ <= 7 و CDate (xRgDateVal) - التاريخ> 0 ثم في رمز VBA يعني أن تاريخ الاستحقاق يجب أن يكون أكبر من يوم واحد وأقل من أو يساوي 1 أيام. يمكنك تغييره كما تريد.

3. صحافة ال مفتاح F5 لتشغيل الكود. في أول ظهور كوتولس ل إكسيل في مربع الحوار ، يرجى تحديد نطاق عمود تاريخ الاستحقاق ثم النقر فوق OK زر. انظر لقطة الشاشة:

4. ثم الثانية كوتولس ل إكسيل ينبثق مربع الحوار ، يرجى تحديد نطاق العمود المقابل الذي يحتوي على عناوين البريد الإلكتروني للمستلمين ، وانقر فوق OK زر. انظر لقطة الشاشة:

5. في الماضي كوتولس ل إكسيل ، حدد المحتوى الذي تريد عرضه في نص البريد الإلكتروني ، ثم انقر فوق OK .

بعد ذلك ، سيتم إنشاء بريد إلكتروني تلقائيًا مع المستلم المحدد والموضوع والجسم المدرجين إذا كان تاريخ الاستحقاق في العمود C أقل من أو يساوي 7 أيام. الرجاء الضغط على أرسل زر لإرسال البريد الإلكتروني.

ملاحظة:

1. كل بريد إلكتروني تم إنشاؤه يتوافق مع تاريخ استحقاق. على سبيل المثال ، إذا كانت هناك ثلاثة تواريخ استحقاق تفي بالمعايير ، فسيتم إنشاء ثلاث رسائل بريد إلكتروني تلقائيًا.

2. لن يتم تشغيل هذا الرمز إذا لم تكن هناك تواريخ تفي بالمعايير.

3. يعمل رمز VBA فقط عند استخدام Outlook كبرنامج بريد إلكتروني.


مقالات ذات صلة:

أفضل أدوات إنتاجية المكتب

الميزات الشعبية: البحث عن التكرارات أو تمييزها أو تحديدها   |  حذف الصفوف الفارغة   |  دمج الأعمدة أو الخلايا دون فقدان البيانات   |   جولة بدون صيغة 
سوبر بحث: معايير متعددة VLookup    VLookup ذات القيمة المتعددة  |   VLookup عبر أوراق متعددة   |   بحث غامض ....
قائمة منسدلة متقدمة: إنشاء القائمة المنسدلة بسرعة   |  القائمة المنسدلة التابعة   |  قائمة منسدلة متعددة التحديد ....
مدير العمود: إضافة عدد محدد من الأعمدة  |  نقل الأعمدة  |  تبديل حالة رؤية الأعمدة المخفية  |  مقارنة النطاقات والأعمدة 
الميزات المميزة: التركيز على الشبكة   |  عرض تصميم   |   شريط الفورمولا الكبير    مدير المصنفات والأوراق   |  مكتبة الموارد (النص السيارات)   |  منتقي التاريخ   |  اجمع أوراق العمل   |  تشفير/فك تشفير الخلايا    إرسال رسائل البريد الإلكتروني عن طريق القائمة   |  سوبر تصفية   |   مرشح خاص (تصفية غامق / مائل / يتوسطه خط ...) ...
أفضل 15 مجموعة أدوات12 نص الأدوات (إضافة نص, إزالة الأحرف، ...)   |   +50 رسم الأنواع (مخطط جانت، ...)   |   40+ عملي الصيغ (احسب العمر على أساس تاريخ الميلاد، ...)   |   19 إدخال الأدوات (أدخل رمز الاستجابة السريعة, إدراج صورة من المسار، ...)   |   12 تحويل الأدوات (أرقام إلى كلمات, نتيجة تحويل عملة، ...)   |   7 دمج وتقسيم الأدوات (الجمع بين الصفوف المتقدمة, تقسيم الخلايا، ...)   |   ... و اكثر

عزز مهاراتك في Excel باستخدام Kutools for Excel، واختبر كفاءة لم يسبق لها مثيل. يقدم Kutools for Excel أكثر من 300 ميزة متقدمة لتعزيز الإنتاجية وتوفير الوقت.  انقر هنا للحصول على الميزة التي تحتاجها أكثر...

علامة تبويب kte 201905


يجلب Office Tab الواجهة المبوبة إلى Office ، ويجعل عملك أسهل بكثير

  • تمكين التحرير والقراءة المبوبة في Word و Excel و PowerPointوالناشر والوصول و Visio والمشروع.
  • فتح وإنشاء مستندات متعددة في علامات تبويب جديدة من نفس النافذة ، بدلاً من النوافذ الجديدة.
  • يزيد من إنتاجيتك بنسبة 50٪ ، ويقلل مئات النقرات بالماوس كل يوم!
Comments (127)
Rated 4.5 out of 5 · 1 ratings
This comment was minimized by the moderator on the site
Anyone can help me, I have come a long way with this topic, but I am running into 1 problem. In cell J:Y, a formula produces a value for how long the project will last. This changes every day because the deadline is getting closer and closer. Now I want him to automatically send me an email when there are 14 days left. This works if I simply enter 14 here myself, but not if there is a formula in it. Who can help me to automatically recognize that the 14-day period has been reached based on the formula?
This comment was minimized by the moderator on the site
I want to apply this macro to different sheets in my workbook, but each sheet is different. Adding a second module means the first one no longer works.

Could you advise me please?
This comment was minimized by the moderator on the site
Hi Annie,

The code can be applied to different worksheets, not just the current one. After running the code, select the desired worksheet tab and then the cell range.
This comment was minimized by the moderator on the site
Olá, eu trabalho com calibrações de equipamentos controlados pelo inmetro, eu fiz uma planilha com a data de vencimento da calibração de cada equipamento, é possível quando a data estiver chegando próximo ao vencimento tipo uns 30 dias, o excel enviar um email automático para que eu possa lembrar?
This comment was minimized by the moderator on the site
Bonjour , je suis nouveau sur VBA

Comment faire pour quand les dates change ?
This comment was minimized by the moderator on the site
Hi theo charvet,

Sorry I don't quite understand your question. For clarity, please attach a screenshot with your data and desired results.
This comment was minimized by the moderator on the site
Hallo Zusammen,

ich möchte an die generierte Email immer die gleiche Datei anhägen.
Ist das irgendwie machbar? Ich bedanke mich recht herzlich vorab.

Hello all,

I would like to attach always the same file to the generated email.
Is this somehow possible? Thank you very much in advance.
This comment was minimized by the moderator on the site
Hi Sandro,

You need to add the following line above the .Display line in the VBA code.
Please replace the file path with the file path of your own.
.Attachments.Add "D:\Work\Month\Dec\Word.docx"
This comment was minimized by the moderator on the site
Hallo Zusammen,

danke für den Code.

Ich möchte an die generierte Email, immer den gleichen Anhang setzten. Mit meinem primitiven Versuch:

.attachments.add "Pfad\Dateiname" bin ich leider nicht weiter gekommen.

Kann mir hier vielleicht wer helfen? :)
This comment was minimized by the moderator on the site
Hi ,

I was using this and everything goes well but after step 5 I didn't see send button , please help. I need this very urgently.
Rated 4.5 out of 5
This comment was minimized by the moderator on the site
Hi Vani,
Does the new message window pop up? The Send button displays in the message window.
If there is no eligible date, the message will not be created.
This comment was minimized by the moderator on the site
Hi!
I am trialling and it seems that always need to open and run the module for the email to be created.
How do I automatically run this even if the worksheet is not open?
This comment was minimized by the moderator on the site
Hi Mychel,
Can you describe the problem more clearly? By the way, you can't run a macro if the workbook is not open.
This comment was minimized by the moderator on the site
Hi,

Can this code be amended where it will send two lines of information to one recipient? Say i have two due dates, rather than sending two emails to the same person, can they be merged into one?

Thanks
A
This comment was minimized by the moderator on the site
Hi,
Suppose there are two tasks are assiged to the same recipient. When the due dates of these two tasks meet the conditions, an email is generated that includes the corresponding information of the tasks in the email body. Please try the following VBA code. Hope I can help.

Public Sub CheckAndSendMail2()
'Updated by Extendoffice 2022/08/23
    Dim xRgDate As Range
    Dim xRgSend As Range
    Dim xRgText As Range
    Dim xRgDone As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xLastRow, xJ As Long
    Dim vbCrLf As String
    Dim xMailBody As String
    Dim xRgDateVal As String
    Dim xRgSendVal As String
    Dim xMailSubject As String
    Dim xStrMail, xStrFind As String
    Dim xBol As Boolean
    Dim i As Long
  ' On Error Resume Next
    Set xRgDate = Application.InputBox("Please select the due date column:", "KuTools For Excel", , , , , , 8)
    If xRgDate Is Nothing Then Exit Sub
    Set xRgSend = Application.InputBox("Please select the recipients?email column:", "KuTools For Excel", , , , , , 8)
    If xRgSend Is Nothing Then Exit Sub
    Set xRgText = Application.InputBox("Select the column with reminded content in your email:", "KuTools For Excel", , , , , , 8)
    If xRgText Is Nothing Then Exit Sub
    xLastRow = xRgDate.Rows.Count
    Set xRgDate = xRgDate(1)
    Set xRgSend = xRgSend(1)
    Set xRgText = xRgText(1)
  Set xOutApp = CreateObject("Outlook.Application")
    xStrMail = ""
    For i = 1 To xLastRow
        xRgDateVal = ""
        xRgDateVal = xRgDate.Offset(i - 1).Value
        xBol = True
        If xRgDateVal <> "" Then
        If CDate(xRgDateVal) - Date <= 7 And CDate(xRgDateVal) - Date > 0 Then
            xRgSendVal = xRgSend.Offset(i - 1).Value
            xStrFind = xRgSendVal & ";"
            If InStr(xStrMail, xStrFind) > 0 Then
                xBol = False
            End If
            If xBol Then
            xStrMail = xStrMail & xStrFind
            xMailSubject = xRgText.Offset(i - 1).Value & " on " & xRgDateVal
            vbCrLf = "<br><br>"
            xMailBody = "<HTML><BODY>"
            xMailBody = xMailBody & "Dear " & xRgSendVal & vbCrLf
            xMailBody = xMailBody & "Text : " & xRgText.Offset(i - 1).Value & vbCrLf
            For xJ = i + 1 To xLastRow
                If CDate(xRgDate.Offset(xJ - 1).Value) - Date <= 7 And CDate(xRgDate.Offset(xJ - 1).Value) - Date > 0 Then
                    If xRgSendVal = xRgSend.Offset(xJ - 1).Value Then
                        xMailBody = xMailBody & "Text : " & xRgText.Offset(xJ - 1).Value & vbCrLf
                    End If
                End If
            Next
            xMailBody = xMailBody & "</BODY></HTML>"
            Set xMailItem = xOutApp.CreateItem(0)
            With xMailItem
                .Subject = xMailSubject
                .To = xRgSendVal
                .HTMLBody = xMailBody
                .Display
                '.Send
            End With
            Set xMailItem = Nothing
        End If
        End If
    End If
    Next
    Set xOutApp = Nothing
End Sub
This comment was minimized by the moderator on the site
Hello, I have an additional column. 'Subject' column with different subject for each mail. How do I add the Subject Loop in the above VBA Code?
This comment was minimized by the moderator on the site
Hi Pranay,
The following code can do you a favor. Please give it a try.
Public Sub CheckAndSendMail()
'Updated by Extendoffice 20220729
    Dim xRgDate As Range
    Dim xRgSend As Range
    Dim xRgSubject As Range
    Dim xRgText As Range
    Dim xRgDone As Range
    Dim xOutApp As Object
    Dim xMailItem As Object
    Dim xLastRow As Long
    Dim vbCrLf As String
    Dim xMailBody As String
    Dim xRgDateVal As String
    Dim xRgSendVal As String
    'Dim xRgSubject As String
    Dim i As Long
    On Error Resume Next
    Set xRgDate = Application.InputBox("Please select the due date column:", "KuTools For Excel", , , , , , 8)
    If xRgDate Is Nothing Then Exit Sub
    Set xRgSend = Application.InputBox("Please select the recipients' email column:", "KuTools For Excel", , , , , , 8)
    If xRgSend Is Nothing Then Exit Sub
    Set xRgSubject = Application.InputBox("Please select the subject column:", "KuTools For Excel", , , , , , 8)
    If xRgSubject Is Nothing Then Exit Sub
    Set xRgText = Application.InputBox("Select the column with reminded content in your email:", "KuTools For Excel", , , , , , 8)
    If xRgText Is Nothing Then Exit Sub
    xLastRow = xRgDate.Rows.Count
    Set xRgDate = xRgDate(1)
    Set xRgSend = xRgSend(1)
    Set xRgSubject = xRgSubject(1)
    Set xRgText = xRgText(1)
    Set xOutApp = CreateObject("Outlook.Application")
    For i = 1 To xLastRow
        xRgDateVal = ""
        xRgDateVal = xRgDate.Offset(i - 1).Value
        If xRgDateVal <> "" Then
        If CDate(xRgDateVal) - Date <= 7 And CDate(xRgDateVal) - Date > 0 Then
            xRgSendVal = xRgSend.Offset(i - 1).Value
            xMailSubject = xRgSubject.Offset(i - 1).Value & " on " & xRgDateVal
            vbCrLf = "<br><br>"
            xMailBody = "<HTML><BODY>"
            xMailBody = xMailBody & "Dear " & xRgSendVal & vbCrLf
            xMailBody = xMailBody & "Text : " & xRgText.Offset(i - 1).Value & vbCrLf
            xMailBody = xMailBody & "</BODY></HTML>"
            Set xMailItem = xOutApp.CreateItem(0)
            With xMailItem
                .Subject = xMailSubject
                .To = xRgSendVal
                .HTMLBody = xMailBody
                .Display
                '.Send
            End With
            Set xMailItem = Nothing
        End If
    End If
    Next
    Set xOutApp = Nothing
End Sub
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