Enviar email com avisos - Duvidas

Question

Bom dia galera,

Tenho uma plantilha de excel que tenho um codigo VBA para enviar avisos sobre quais veiculos estão sem inspeção ou se a data estar perto.

Mas eu agora queria adicionar outras datas alem da inspeção. A ideia seria que num Range de D2:E64 ao encontrar uma data abaixo do dia de hoje ele envia se um alerta e identifica-se no email se era inspeção ou a licença de transporte que estava fora de prazo.

Outra ideia era se é possivel juntar todos os avisos de todos os veiculos num só email em vez de mandar um aviso por veiculo em cada email.

Codigo:

Sub Verificar()
    Dim rCell As Range
    Dim lRow, al, av As Long
    Dim appOutlook As Object
    Dim olMail As Object
    al = 0
    av = 0
    ur = 0
    lRow = Range("D1048576").End(xlUp).Row
    For Each rCell In Range("D2:D" & lRow)
        If rCell = Empty Then
        MsgBox ("Falta a data da proxima inspecção do veiculo " & rCell(1, 0))
        GoTo vazio
        End If
        If rCell = "NOVO" Then
        End If
        If rCell < (Now() + 8) Then
        Dias = DateDiff("d", Now, rCell)
            On Error Resume Next
            Set appOutlook = GetObject(, "Outlook.Application")
            If appOutlook Is Nothing Then
                Set appOutlook = CreateObject("Outlook.Application")
            End If
            On Error GoTo 0
            Set olMail = appOutlook.CreateItem(0)
            If Dias < 0 Then
                With olMail
                    .to = "emailll"
                    .Subject = "URGENTE INSPEÇÃO " & rCell(1, 0) & "- AUT."
                    .Body = "Passaram " & Dias & " dias da data de levar o veiculo com a matricula " & rCell(1, 0) & " à inspecção" & vbNewLine & "Mensagem enviada pelo sistema."
                    .Send
                End With
                ur = ur + 1
                rCell(1, 5).Value = "URGENTE"
            End If
            If Dias > 0 Then
                With olMail
                    .to = "emailll"
                    .Subject = "ALERTA INSPEÇÃO " & rCell(1, 0) & "- AUT."
                    .Body = "Faltam " & Dias & " dias para levar o veiculo com a matricula " & rCell(1, 0) & " à inspecção" & vbNewLine & "Mensagem enviada pelo sistema."
                    .Send
                End With
                al = al + 1
                rCell(1, 5).Value = "ALERTADO"
            End If
        End If
        If rCell < (Now() + 30) And rCell > (Now() + 8) Then
        av = av + 1
        Dias = DateDiff("d", Now, rCell)
        On Error Resume Next
            Set appOutlook = GetObject(, "Outlook.Application")
            If appOutlook Is Nothing Then
                Set appOutlook = CreateObject("Outlook.Application")
            End If
            On Error GoTo 0
            Set olMail = appOutlook.CreateItem(0)
            With olMail
                .to = "emailll"
                .Subject = "AVISO INSPEÇÃO " & rCell(1, 0) & "- AUT."
                .Body = "Faltam " & Dias & " dias para levar o veiculo com a matricula " & rCell(1, 0) & " à inspecção" & vbNewLine & "Mensagem enviada pelo sistema."
                .Send
            End With
            rCell(1, 5).Value = "AVISADO"
        End If
        If rCell > (Now() + 30) Then
            rCell(1, 5).Value = " "
        End If
vazio:
    Next rCell
MsgBox ("Foram enviados " & ur & " Urgentes, " & al & " Alertas e " & av & " Avisos")
Range("K8").Value = Now()
End Sub

Podem me ajudar?