Sub dat()
Dim CL As Object
Dim X
Application.ScreenUpdating = False
X = Date
Set Rng = Range("d4:d6") '
For Each CL In Rng
If CL > X And CL <> 0 Then
Application.Run ("Autoemail")


End If
Next
Application.ScreenUpdating = True
End Sub
Sub Autoemail()

    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailAddr As String
    Dim Subj As String
    Dim BodyText As String
    
    Foglio1.Select
    

' RR contiene il numero di utenti cui inviare le e-mail (1 per utente)
    RR = Range("B" & Rows.Count).End(xlUp).Row
' I dati iniziano dalla quarta riga
    For i = 4 To RR
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
                  ' La colonna "B" contiene gli indirizzi e-mail dei vari destinatari
                  .To = Cells(i, 2)
                  ' La colonna "C" contiene l'indirizzo e-mail in "Copia per Conoscenza"
                  .CC = "varesi.f@fater.it"

                  .Subject = Cells(i, 5)
                  ' La colonna "E" contiene l testo della e-mail
                  
                  .Body = "THE PROCEDURE IN THE TITLE IS EXPIRED"
                  .Display
        End With
        Set OutMail = Nothing
        Set OutApp = Nothing
        Application.SendKeys "%a"
    Next i

End Sub

Sub Auto_Close()

Dim rng As Range, data1 As Date, data2 As Date, cella
Set rng = Range("d1:D1000")
data1 = Date - 30
data2 = Date
For Each cella In rng
If cella >= data1 And cella <= data2 Then
   
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailAddr As String
    Dim Subj As String
    Dim BodyText As String
    
    Foglio1.Select
    

' RR contiene il numero di utenti cui inviare le e-mail (1 per utente)
    RR = Range("B" & Rows.Count).End(xlUp).Row
' I dati iniziano dalla quarta riga
    i = 4
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        With OutMail
                  ' La colonna "B" contiene gli indirizzi e-mail dei vari destinatari
                  .To = Cells(i, 2)
                  ' La colonna "C" contiene l'indirizzo e-mail in "Copia per Conoscenza"
                  .CC = "varesi.f@fater.it"

                  .Subject = Cells(i, 5)
                  ' La colonna "E" contiene l testo della e-mail
                  
                  .Body = "THE PROCEDURE IN THE TITLE IS GOING TO EXPIRE or IS ALREADY EXPIRED"
                       
                  .Send
        End With
        Set OutMail = Nothing
        Set OutApp = Nothing
        Application.SendKeys "%a"
 
End If


    
Next
End Sub