Gửi cảnh báo bằng mail trước 10 ngày so với ngày trong "cột ngày hết hạn"

Liên hệ QC

Cuongnv0920

Thành viên chính thức
Tham gia
24/3/18
Bài viết
62
Được thích
8
Giới tính
Nam
Chào tất cả mọi người.
minh có 1 file theo dõi thời hạn Hợp đồng
trong file HĐ này có 1 cột là ngày hết hạn của HĐ và mình đã tạo được cảnh báo bằng cách bôi đỏ nếu thời hạn còn 10 ngày
nhưng giờ mong các AE giúp mình, là có thể gửi mail cảnh báo tự động nếu thời hạn HĐ này còn 10 ngày với nội dung mail là Tên của Công ty ký HĐ "ở cột tên cty"
cám ơn nhiều ạ
 

File đính kèm

  • Cảnh báo trạng thái HĐ.xlsm
    18.2 KB · Đọc: 24
Mã:
Sub canhbao()
    Const Email = ""        'Viết email gửi đi vào đây
    Const Subject = "Canh bao het han hop dong"
    
    Dim Body As String
    Dim i As Long, lastrow As Long, a As Integer
    lastrow = Sheets("Sheet1").Cells(Rows.Count, 5).End(xlUp).Row
    a = 10
    For i = 2 To lastrow
        On Error Resume Next
        Cells(i, 6).Value = Cells(i, 5)
        If Cells(i, 6) - Date <= a Then
            Cells(i, 5).Interior.ColorIndex = 3
            Cells(i, 5).Font.ColorIndex = 2
            Cells(i, 6).Value = "Canh bao"
            Body = Body & Chr(10) & Cells(i, 2) & " - " & Cells(i, 3)
        Else
            Cells(i, 5).Font.ColorIndex = vbBlack
            Cells(i, 5).Interior.ColorIndex = 2
            Cells(i, 6).Value = ""
        End If
    Next
    If SendMail(Email, Subject, Body, "") = True Then MsgBox "Da gui canh bao"
End Sub
Function SendMail(Email, S, Body, Attach) As Boolean
    On Error Resume Next
    Err.Clear
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .to = Email
                .Subject = S
                .Body = Body
                If Attach <> "" Then
                    .Attachments.Add Attach
                End If
                DoEvents
                .send
            End With
        Set OutMail = Nothing
        Set OutApp = Nothing
If Err.Number = 0 Then SendMail = True Else SendMail = False
End Function
Bác thử như vậy xem có được không?
 
Upvote 0
Mã:
Sub canhbao()
    Const Email = ""        'Viết email gửi đi vào đây
    Const Subject = "Canh bao het han hop dong"
   
    Dim Body As String
    Dim i As Long, lastrow As Long, a As Integer
    lastrow = Sheets("Sheet1").Cells(Rows.Count, 5).End(xlUp).Row
    a = 10
    For i = 2 To lastrow
        On Error Resume Next
        Cells(i, 6).Value = Cells(i, 5)
        If Cells(i, 6) - Date <= a Then
            Cells(i, 5).Interior.ColorIndex = 3
            Cells(i, 5).Font.ColorIndex = 2
            Cells(i, 6).Value = "Canh bao"
            Body = Body & Chr(10) & Cells(i, 2) & " - " & Cells(i, 3)
        Else
            Cells(i, 5).Font.ColorIndex = vbBlack
            Cells(i, 5).Interior.ColorIndex = 2
            Cells(i, 6).Value = ""
        End If
    Next
    If SendMail(Email, Subject, Body, "") = True Then MsgBox "Da gui canh bao"
End Sub
Function SendMail(Email, S, Body, Attach) As Boolean
    On Error Resume Next
    Err.Clear
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .to = Email
                .Subject = S
                .Body = Body
                If Attach <> "" Then
                    .Attachments.Add Attach
                End If
                DoEvents
                .send
            End With
        Set OutMail = Nothing
        Set OutApp = Nothing
If Err.Number = 0 Then SendMail = True Else SendMail = False
End Function
Bác thử như vậy xem có được không?


Cám ơn bác nhiều nhé. Mình thử thì thời hạn <= 10 ngày thì đã gửi nội dung oke. Nhưng trên 10 thì nó vẫn gửi mail nhưng ko có nội dung. Mình muốn nếu trên 10 ngày thì nó ko gửi luôn.
Tạ ơn bác nhiều, mong bác giúp lần nữa
 
Upvote 0
Cám ơn bác nhiều nhé. Mình thử thì thời hạn <= 10 ngày thì đã gửi nội dung oke. Nhưng trên 10 thì nó vẫn gửi mail nhưng ko có nội dung. Mình muốn nếu trên 10 ngày thì nó ko gửi luôn.
Tạ ơn bác nhiều, mong bác giúp lần nữa
Mã:
Sub canhbao()
    Const Email = ""
    Const Subject = "Canh bao het han hop dong"
    
    Dim Body As String
    Dim i As Long, lastrow As Long, a As Integer
    lastrow = Sheets("Sheet1").Cells(Rows.Count, 5).End(xlUp).Row
    a = 10
    Body = ""
    For i = 2 To lastrow
        On Error Resume Next
        Cells(i, 6).Value = Cells(i, 5)
        If Cells(i, 6) - Date <= a Then
            Cells(i, 5).Interior.ColorIndex = 3
            Cells(i, 5).Font.ColorIndex = 2
            Cells(i, 6).Value = "Canh bao"
            Body = Body & Chr(10) & Cells(i, 2) & " - " & Cells(i, 3)
        Else
            Cells(i, 5).Font.ColorIndex = vbBlack
            Cells(i, 5).Interior.ColorIndex = 2
            Cells(i, 6).Value = ""
        End If
    Next
    If Body <> "" Then
        If SendMail(Email, Subject, Body, "") = True Then MsgBox "Da gui canh bao" else msgbox "Gui mail bi loi"
    End If
End Sub
Function SendMail(Email, S, Body, Attach) As Boolean
    On Error Resume Next
    Err.Clear
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .to = Email
                .Subject = S
                .Body = Body
                If Attach <> "" Then
                    .Attachments.Add Attach
                End If
                DoEvents
                .send
            End With
        Set OutMail = Nothing
        Set OutApp = Nothing
If Err.Number = 0 Then SendMail = True Else SendMail = False
End Function
bác xem thử đã được chưa nhé!
 
Upvote 0
Mã:
Sub canhbao()
    Const Email = ""
    Const Subject = "Canh bao het han hop dong"
   
    Dim Body As String
    Dim i As Long, lastrow As Long, a As Integer
    lastrow = Sheets("Sheet1").Cells(Rows.Count, 5).End(xlUp).Row
    a = 10
    Body = ""
    For i = 2 To lastrow
        On Error Resume Next
        Cells(i, 6).Value = Cells(i, 5)
        If Cells(i, 6) - Date <= a Then
            Cells(i, 5).Interior.ColorIndex = 3
            Cells(i, 5).Font.ColorIndex = 2
            Cells(i, 6).Value = "Canh bao"
            Body = Body & Chr(10) & Cells(i, 2) & " - " & Cells(i, 3)
        Else
            Cells(i, 5).Font.ColorIndex = vbBlack
            Cells(i, 5).Interior.ColorIndex = 2
            Cells(i, 6).Value = ""
        End If
    Next
    If Body <> "" Then
        If SendMail(Email, Subject, Body, "") = True Then MsgBox "Da gui canh bao" else msgbox "Gui mail bi loi"
    End If
End Sub
Function SendMail(Email, S, Body, Attach) As Boolean
    On Error Resume Next
    Err.Clear
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .to = Email
                .Subject = S
                .Body = Body
                If Attach <> "" Then
                    .Attachments.Add Attach
                End If
                DoEvents
                .send
            End With
        Set OutMail = Nothing
        Set OutApp = Nothing
If Err.Number = 0 Then SendMail = True Else SendMail = False
End Function
bác xem thử đã được chưa nhé!

Đã chạy rất tốt rồi bạn
mình có thêm application.ontime để hẹn giờ cho nó :D
có cơ hội giao lưu coffee nhé: Quận 7 hồ chí minh_0935055925
 
Upvote 0
Mã:
Sub canhbao()
    Const Email = ""
    Const Subject = "Canh bao het han hop dong"
   
    Dim Body As String
    Dim i As Long, lastrow As Long, a As Integer
    lastrow = Sheets("Sheet1").Cells(Rows.Count, 5).End(xlUp).Row
    a = 10
    Body = ""
    For i = 2 To lastrow
        On Error Resume Next
        Cells(i, 6).Value = Cells(i, 5)
        If Cells(i, 6) - Date <= a Then
            Cells(i, 5).Interior.ColorIndex = 3
            Cells(i, 5).Font.ColorIndex = 2
            Cells(i, 6).Value = "Canh bao"
            Body = Body & Chr(10) & Cells(i, 2) & " - " & Cells(i, 3)
        Else
            Cells(i, 5).Font.ColorIndex = vbBlack
            Cells(i, 5).Interior.ColorIndex = 2
            Cells(i, 6).Value = ""
        End If
    Next
    If Body <> "" Then
        If SendMail(Email, Subject, Body, "") = True Then MsgBox "Da gui canh bao" else msgbox "Gui mail bi loi"
    End If
End Sub
Function SendMail(Email, S, Body, Attach) As Boolean
    On Error Resume Next
    Err.Clear
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .to = Email
                .Subject = S
                .Body = Body
                If Attach <> "" Then
                    .Attachments.Add Attach
                End If
                DoEvents
                .send
            End With
        Set OutMail = Nothing
        Set OutApp = Nothing
If Err.Number = 0 Then SendMail = True Else SendMail = False
End Function
bác xem thử đã được chưa nhé!

Chào bạn
Sau khi xem bài viết của bạn, nhờ bạn viết code giúp mình với mục đích gửi email cảnh báo. Ở file của mình có nhiều nhóm cột tương ứng với mỗi loại chứng chỉ, mỗi nhóm cột đều có cột thời hạn cần xác định để gửi cảnh báo.
Nhờ bạn giúp với 2 lưu ý sau
a/ Xử lý như file đính kèm với các nhóm cột đều có cấu trúc như nhau.
b/ Xử lý với tình huống: File phát sinh thêm 1 vài nhóm cột, mà nhóm này có cấu trúc không giống các nhóm khác. Cột cần xét thì vẫn có tên trường là "Thời hạn"

Rất mong các anh chị em khác nếu biết thì giúp đỡ.
 

File đính kèm

  • DaoTao.xlsx
    417.2 KB · Đọc: 8
Upvote 0
Chào bạn
Sau khi xem bài viết của bạn, nhờ bạn viết code giúp mình với mục đích gửi email cảnh báo. Ở file của mình có nhiều nhóm cột tương ứng với mỗi loại chứng chỉ, mỗi nhóm cột đều có cột thời hạn cần xác định để gửi cảnh báo.
Nhờ bạn giúp với 2 lưu ý sau
a/ Xử lý như file đính kèm với các nhóm cột đều có cấu trúc như nhau.
b/ Xử lý với tình huống: File phát sinh thêm 1 vài nhóm cột, mà nhóm này có cấu trúc không giống các nhóm khác. Cột cần xét thì vẫn có tên trường là "Thời hạn"

Rất mong các anh chị em khác nếu biết thì giúp đỡ.
nội dung gửi mail như thế nào bạn? tất cả vào một mail? nếu nhiều mail thì gộp theo chứng chỉ hay theo nhân viên?
 
Upvote 0
nội dung gửi mail như thế nào bạn? tất cả vào một mail? nếu nhiều mail thì gộp theo chứng chỉ hay theo nhân viên?

Cảm ơn các bác quan tâm. Em xin cung cấp thêm thông tin ạ

1. Địa chỉ người nhận email, subject email: Thể hiện trong ô B8 và B11 của sheet Data
2. Nội dung email:
Dear sir
Vui lòng kiểm tra hạn của chứng chỉ sau:

Họ tên:
Mã số:
Chức danh:
Số chứng chỉ:
Ngày hết hạn:
Trân trọng
3. Việc gửi mail có 2 tình huống để bác tính xem cách nào hay/dễ thì làm
a/ Mỗi chứng chỉ hết hạn thì gửi 1 email tới người nhận ghi ở ô B8-sheet Data
b/ Gom hết các chứng chỉ hết hạn vào 1 email. Chỉ gửi 1 email trong đó có list các chứng chỉ hết hạn.
Xin cảm ơn
 
Upvote 0
Cảm ơn các bác quan tâm. Em xin cung cấp thêm thông tin ạ

1. Địa chỉ người nhận email, subject email: Thể hiện trong ô B8 và B11 của sheet Data
2. Nội dung email:
Dear sir
Vui lòng kiểm tra hạn của chứng chỉ sau:

Họ tên:
Mã số:
Chức danh:
Số chứng chỉ:
Ngày hết hạn:
Trân trọng
3. Việc gửi mail có 2 tình huống để bác tính xem cách nào hay/dễ thì làm
a/ Mỗi chứng chỉ hết hạn thì gửi 1 email tới người nhận ghi ở ô B8-sheet Data
b/ Gom hết các chứng chỉ hết hạn vào 1 email. Chỉ gửi 1 email trong đó có list các chứng chỉ hết hạn.
Xin cảm ơn
Mình đang làm nhưng có một vài vấn đề.
1. Theo file của bạn thì k gửi 1 email đc do số lượng nhiều quá biến để chứa body mail không đủ
2. Có một vài ô cột thời hạn lại chứa 2 giá trị ngày nên chạy đến đó lại lỗi
3. Gửi từng chứng chỉ thì số lượng nhiều quá ~170 mail nên đang chưa biết nên làm thế nào.
4. mình mới làm được lưu ý a của bạn, còn phần lưu ý b trường hợp thêm nhóm cột không giống thì vẫn chưa biết xử lý thế nào (thêm nhóm cột giống OK)

Bác nào trong diễn đàn có kinh nghiệm vụ này hỗ trợ thêm được không ạ?
 

File đính kèm

  • DaoTao.xlsm
    432.3 KB · Đọc: 11
Upvote 0
Với dữ liệu gửi mail nhiều thì tốt nhất là đính kèm file
 
Upvote 0
Mình đang làm nhưng có một vài vấn đề.
1. Theo file của bạn thì k gửi 1 email đc do số lượng nhiều quá biến để chứa body mail không đủ
2. Có một vài ô cột thời hạn lại chứa 2 giá trị ngày nên chạy đến đó lại lỗi
3. Gửi từng chứng chỉ thì số lượng nhiều quá ~170 mail nên đang chưa biết nên làm thế nào.
4. mình mới làm được lưu ý a của bạn, còn phần lưu ý b trường hợp thêm nhóm cột không giống thì vẫn chưa biết xử lý thế nào (thêm nhóm cột giống OK)

Bác nào trong diễn đàn có kinh nghiệm vụ này hỗ trợ thêm được không ạ?
Bạn ơi
Mặc dù Outlook của mình đã sẵn sàng nhưng dường như file của bạn không gửi được email đi bạn ạ
Outlook có báo Sending, nhưng dù chờ rất lâu cũng không có nhận được email thông báo
Bạn kiểm tra lại giúp nhé
 
Upvote 0

Cho mình hỏi thêm 1 vấn đề

Mình có thêm application.ontime trong workbook để sáng ra 08:00 nó sẽ check và gửi mail
Nhưng đến ngày tiếp theo nó ko gửi nữa. Mình phải tắt đi mở lại nó mới gửi được ngày tiếp theo.
Bạn có cách nào tự refresh để ko phải tắt mở lại ko? Cám ơn bạn nhiều nhé

Private Sub Workbook_Open()
Application.OnTime TimeValue("13:48:00"), "canhbao"
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Cho mình hỏi thêm 1 vấn đề

Mình có thêm application.ontime trong workbook để sáng ra 08:00 nó sẽ check và gửi mail
Nhưng đến ngày tiếp theo nó ko gửi nữa. Mình phải tắt đi mở lại nó mới gửi được ngày tiếp theo.
Bạn có cách nào tự refresh để ko phải tắt mở lại ko? Cám ơn bạn nhiều nhé

Private Sub Workbook_Open()
Application.OnTime TimeValue("13:48:00"), "canhbao"
End Sub
Bạn thử them dòng sau vào cuối sub canhbao

Mã:
Dim ThoiGian as Date
ThoiGian=date+1+TimeSerial(0, 0, 0)'Thoi gian chay sub hang ngay ghi vao day
Application.OnTime ThoiGian, "canhbao", , True
 
Lần chỉnh sửa cuối:
Upvote 0
Bạn thử them dòng sau vào cuối sub canhbao

Mã:
Dim ThoiGian as Date
ThoiGian=date+1+TimeSerial(0, 0, 0)'Thoi gian chay sub hang ngay ghi vao day
Application.OnTime ThoiGian, "canhbao", , True


Mình đã thử cách khác cũng rất ok làm như sau:
Mã:
Private Sub Workbook_Open()
     Application.OnTime TimeValue("21:24:00"), "canhbao"
     Application.OnTime TimeValue("21:25:00"), "dong"
     Application.OnTime TimeValue("21:26:00"), "mo"
End Sub

Tương ứng với các sub:

Sub canhbao()
'Nhưng riêng với cái Sub này khi gửi mail nó hiên 1 cái Msgbox, nó sẽ làm cho sub dong() không đóng được
'mình có thử xóa phần msgbox của bạn nhưng bị báo lỗi
End Sub

Sub dong()
    ActiveWorkbook.Close Savechanges:=True
End Sub

Sub mo()
    Application.Workbooks.Open ("C:\Users\cuong\Desktop\VBA\Canh bao HD.xlsm")
End Sub
 
Upvote 0

với đoạn code bác cho mình chạy thì hôm nay mình phát hiện ra 1 vấn đề như sau"
Nếu danh sách ngày ở cột số 5 nếu không có ngày nào đến hạn để cánh báo tức là <=10 ngày
thì đoạn code vẫn gửi đi 1 mail cảnh báo nhưng ko có nội dung của cột 2 và cột 3
bác có cách nào mà khi danh sách ở cột 5 nếu code tự check mà ko có ngày nào <=10 sẽ không yêu cầu outlook gửi mail ko
tạ ơn bác nhiều :D
Mã:
Sub canhbao()
    Const Email = ""
    Const Subject = "Canh bao het han hop dong"
    
    Dim Body As String
    Dim i As Long, lastrow As Long, a As Integer
    lastrow = Sheets("Sheet1").Cells(Rows.Count, 5).End(xlUp).Row
    a = 10
    Body = ""
    For i = 2 To lastrow
        On Error Resume Next
        Cells(i, 6).Value = Cells(i, 5)
        If Cells(i, 6) - Date <= a Then
            Cells(i, 5).Interior.ColorIndex = 3
            Cells(i, 5).Font.ColorIndex = 2
            Cells(i, 6).Value = "Canh bao"
            Body = Body & Chr(10) & Cells(i, 2) & " - " & Cells(i, 3)
        Else
            Cells(i, 5).Font.ColorIndex = vbBlack
            Cells(i, 5).Interior.ColorIndex = 2
            Cells(i, 6).Value = ""
        End If
    Next
    If Body <> "" Then
        If SendMail(Email, Subject, Body, "") = True Then MsgBox "Da gui canh bao" else msgbox "Gui mail bi loi"
    End If
End Sub
Function SendMail(Email, S, Body, Attach) As Boolean
    On Error Resume Next
    Err.Clear
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .to = Email
                .Subject = S
                .Body = Body
                If Attach <> "" Then
                    .Attachments.Add Attach
                End If
                DoEvents
                .send
            End With
        Set OutMail = Nothing
        Set OutApp = Nothing
If Err.Number = 0 Then SendMail = True Else SendMail = False
End Function
 
Upvote 0
với đoạn code bác cho mình chạy thì hôm nay mình phát hiện ra 1 vấn đề như sau"
Nếu danh sách ngày ở cột số 5 nếu không có ngày nào đến hạn để cánh báo tức là <=10 ngày
thì đoạn code vẫn gửi đi 1 mail cảnh báo nhưng ko có nội dung của cột 2 và cột 3
bác có cách nào mà khi danh sách ở cột 5 nếu code tự check mà ko có ngày nào <=10 sẽ không yêu cầu outlook gửi mail ko
tạ ơn bác nhiều :D
Mã:
Sub canhbao()
    Const Email = ""
    Const Subject = "Canh bao het han hop dong"
   
    Dim Body As String
    Dim i As Long, lastrow As Long, a As Integer
    lastrow = Sheets("Sheet1").Cells(Rows.Count, 5).End(xlUp).Row
    a = 10
    Body = ""
    For i = 2 To lastrow
        On Error Resume Next
        Cells(i, 6).Value = Cells(i, 5)
        If Cells(i, 6) - Date <= a Then
            Cells(i, 5).Interior.ColorIndex = 3
            Cells(i, 5).Font.ColorIndex = 2
            Cells(i, 6).Value = "Canh bao"
            Body = Body & Chr(10) & Cells(i, 2) & " - " & Cells(i, 3)
        Else
            Cells(i, 5).Font.ColorIndex = vbBlack
            Cells(i, 5).Interior.ColorIndex = 2
            Cells(i, 6).Value = ""
        End If
    Next
    If Body <> "" Then
        If SendMail(Email, Subject, Body, "") = True Then MsgBox "Da gui canh bao" else msgbox "Gui mail bi loi"
    End If
End Sub
Function SendMail(Email, S, Body, Attach) As Boolean
    On Error Resume Next
    Err.Clear
    Dim OutApp As Object
    Dim OutMail As Object
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
            With OutMail
                .to = Email
                .Subject = S
                .Body = Body
                If Attach <> "" Then
                    .Attachments.Add Attach
                End If
                DoEvents
                .send
            End With
        Set OutMail = Nothing
        Set OutApp = Nothing
If Err.Number = 0 Then SendMail = True Else SendMail = False
End Function
Bác sửa dòng này: For i = 2 To lastrow => For i = 4 To lastrow
 
Upvote 0
Web KT
Back
Top Bottom