Macro Excel para calcular vencimiento de fechas y enviar email

A continuación muestro una macro de Excel ,que puede resultar útil para validación de fechas entre columnas, y enviar alertas por email a traves de outlook:

Sub Vencimiento()
    Dim nFila As Double
    Dim rCelda As Range
    Dim sVencimiento As String
    Dim n As Double
    Dim sFactVence As String
    Dim bFactVencidas As Boolean
 
 
    'Contamos Filas
    bFactVencidas = False
    nFila = Worksheets("FINAL").Range("A" & Rows.Count).End(xlUp).Row
    
    'Revisamos la fecha de vencimiento 
    'si está vencida o si vence a 1,2, 3, 4 o mas meses
    For Each rCelda In Worksheets("FINAL").Range("D2:D" & nFila)
        Select Case (rCelda.Value - Date)
            Case Is >= 120
                sVencimiento = "Mayor a 4 Meses"
            Case Is >= 90
                sVencimiento = "4 Meses"
            Case Is >= 60
                sVencimiento = "3 Meses"
            Case Is >= 30
                sVencimiento = "2 Meses"
            Case Is > 0
                sVencimiento = "1 Mes"
            Case Else
                sVencimiento = "Vencida"
        End Select
        rCelda.Offset(0, 11).Value = sVencimiento
    Next
    
    'Revisamos si paso de vencimiento
    For Each rCelda In Worksheets("FINAL").Range("O2:O" & nFila)
        If rCelda.Value <> "Vencida" Then
           sFactVence = sFactVence & "--- " & Chr(10) & _
           "VENCIMIENTO EN : " & rCelda.Value & Chr(10) & _
           "CAMPO1: " & rCelda.Offset(0, -13).Value & Chr(10) & _
           "CAMPO2: " & rCelda.Offset(0, -12).Value & Chr(10) & _
           "CAMPO3: " & rCelda.Offset(0, -11).Value & Chr(10) & _
           "--- " & Chr(10) & Chr(10)
            'rCelda.Value = "SI"
            bFactVencidas = True
        End If
    Next
    
    'enviamos el correo
    If bFactVencidas = True Then
        Call Enviar_Correo(sFactVence)
    End If
End Sub

Sub Enviar_Correo(ByVal sFacturas As String)
    
    Set fase1 = CreateObject("outlook.application")

    Set fase2 = fase1.CreateItem(olMailItem)
    fase2.To = "midir@email.com"
    fase2.Subject = "Informes "
    
    fase2.Body = "Informes  " & Chr(10) & _
                 "_________ " & Chr(10) & Chr(10) & sFacturas
    
    'fase2.Attachments.Add ActiveWorkbook.FullName
    
    fase2.Send
    
    Set correo1 = Nothing
    
    Set correo2 = Nothing
End Sub

una web muy util para realizar este tipo de macros -> http://www.rondebruin.nl/win/section1.htm