TÌM KIẾM NGÀY SINH NHẬT CỦA KHÁCH HÀNG & CẢNH BÁO QUA MAIL

[Cuongnv0920]

Xin chào tất cả các A/C GPE.
Trước đây mình dùng file này để cảnh báo các hợp đồng hết hạn qua email trước 01 ngày so với thời gian của hệ thống. và gửi cho tới khi nào mình cập nhật lại ngày mới cho nó thì không cảnh báo nữa.
Nhưng giờ mình muốn dùng file này để nhắc nhở ngày sinh nhật của Khách hàng qua email, nhưng hiện tại theo đoạn code thì đang so sánh "Date" (dd/MM/yyyy) thời gian của hệ thống, mình chỉ muốn so sánh (dd/MM) thôi, và gửi nhắc qua email trước 01 ngày.
VD: ngày sinh nhật của Khách hàng là 20/09/1991, nhưng giờ hệ thống là 20/09/2019, nếu thỏa mãn (ngày/tháng), thì sẽ gửi nhắc nhở trước 01 ngày. tức là cứ ngày 19/09 hàng năm sẽ tự động gửi nhắc nhở KH này qua mail. và tới ngày 20/09 sẽ không gửi ngày nhắc nhở của KH này nữa. "tức là chỉ nhắc 1 lần"

Sub SN_KH()
    Worksheets("SN_KH").Activate
    Const Email = "cuongnv0920@gmail.com"
    Const Subject = "NHAC NGAY SINH NHAT KHACH HANG"
    
    Dim Body As String
    Dim i As Long, lastrow As Long, a As Integer
    lastrow = Sheets("SN_KH").Cells(Rows.Count, 5).End(xlUp).Row
    a = 1
    Body = ""
    For i = 4 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 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

 

[Phuocam]

Xin chào tất cả các A/C GPE.
Trước đây mình dùng file này để cảnh báo các hợp đồng hết hạn qua email trước 01 ngày so với thời gian của hệ thống. và gửi cho tới khi nào mình cập nhật lại ngày mới cho nó thì không cảnh báo nữa.
Nhưng giờ mình muốn dùng file này để nhắc nhở ngày sinh nhật của Khách hàng qua email, nhưng hiện tại theo đoạn code thì đang so sánh "Date" (dd/MM/yyyy) thời gian của hệ thống, mình chỉ muốn so sánh (dd/MM) thôi, và gửi nhắc qua email trước 01 ngày.
VD: ngày sinh nhật của Khách hàng là 20/09/1991, nhưng giờ hệ thống là 20/09/2019, nếu thỏa mãn (ngày/tháng), thì sẽ gửi nhắc nhở trước 01 ngày. tức là cứ ngày 19/09 hàng năm sẽ tự động gửi nhắc nhở KH này qua mail. và tới ngày 20/09 sẽ không gửi ngày nhắc nhở của KH này nữa. "tức là chỉ nhắc 1 lần"

Sub SN_KH()
    Worksheets("SN_KH").Activate
    Const Email = "cuongnv0920@gmail.com"
    Const Subject = "NHAC NGAY SINH NHAT KHACH HANG"
   
    Dim Body As String
    Dim i As Long, lastrow As Long, a As Integer
    lastrow = Sheets("SN_KH").Cells(Rows.Count, 5).End(xlUp).Row
    a = 1
    Body = ""
    For i = 4 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 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

Tạo một cột phụ với công thức:

=EDATE(E4,(YEAR(TODAY())-YEAR(E4))*12)

rồi sử dụng code cũ.

 

[Cuongnv0920]

Tạo một cột phụ với công thức:

=EDATE(E4,(YEAR(TODAY())-YEAR(E4))*12)

rồi sử dụng code cũ.

Cám ơn bác nhiều, mình sẽ thử xem nào

 

[SA_DQ]

Bạn muốn có macro, thì đây xin mời bạn:

Sub NSN(Dat As Date)
 Dim Arr()
 Dim Rws As Long, J As Long, NT As Long, NT0 As Long
  
 With Sheets("GPE")
    Rws = .[d2].CurrentRegion.Rows.Count
    .Columns("D:D").Interior.ColorIndex = 0
    For J = 2 To Rws
        If NumDat(Cells(J, "D").Value) = NumDat(Dat, 1) Then
            Cells(J, "D").Interior.ColorIndex = 38
        End If
        If NumDat(Cells(J, "D").Value) = NumDat(Dat, 2) Or _
            NumDat(Cells(J, "D").Value) = NumDat(Dat, 3) Then
            Cells(J, "D").Interior.ColorIndex = 40
        End If
        If NumDat(Cells(J, "D").Value) = NumDat(Dat, 4) Or _
            NumDat(Cells(J, "D").Value) = NumDat(Dat, 5) Then
            Cells(J, "D").Interior.ColorIndex = 35
        End If
    Next J
 End With
End Sub

Function NumDat(Dat As Date, Optional Num As Byte = 0) As Long
 Dim J As Integer
If Num = 0 Then
    NumDat = Month(Dat) * 100 + Day(Dat)
Else
    For J = 1 To 5
        NumDat = Month(Dat - J) * 100 + Day(Dat - J)
        If J = Num Then Exit Function
    Next J
 End If
End Function

 

[Cuongnv0920]

Bạn muốn có macro, thì đây xin mời bạn:

Sub NSN(Dat As Date)
Dim Arr()
Dim Rws As Long, J As Long, NT As Long, NT0 As Long
 
With Sheets("GPE")
    Rws = .[d2].CurrentRegion.Rows.Count
    .Columns("D:D").Interior.ColorIndex = 0
    For J = 2 To Rws
        If NumDat(Cells(J, "D").Value) = NumDat(Dat, 1) Then
            Cells(J, "D").Interior.ColorIndex = 38
        End If
        If NumDat(Cells(J, "D").Value) = NumDat(Dat, 2) Or _
            NumDat(Cells(J, "D").Value) = NumDat(Dat, 3) Then
            Cells(J, "D").Interior.ColorIndex = 40
        End If
        If NumDat(Cells(J, "D").Value) = NumDat(Dat, 4) Or _
            NumDat(Cells(J, "D").Value) = NumDat(Dat, 5) Then
            Cells(J, "D").Interior.ColorIndex = 35
        End If
    Next J
End With
End Sub

Function NumDat(Dat As Date, Optional Num As Byte = 0) As Long
Dim J As Integer
If Num = 0 Then
    NumDat = Month(Dat) * 100 + Day(Dat)
Else
    For J = 1 To 5
        NumDat = Month(Dat - J) * 100 + Day(Dat - J)
        If J = Num Then Exit Function
    Next J
End If
End Function

Cám ơn bác SA_DQ nhiều ak