![](data:image/svg+xml, %3Csvg xmlns='http://www.w3.org/2000/svg' height='64' class='font-weight-bold' style='font: 600 30.11764705882353px "SegoeUI", Arial' width='64'%3E%3Ccircle fill='hsl(128, 8%, 22%)' cx='32' cy='32' r='32' /%3E%3Ctext x='50%25' y='55%25' dominant-baseline='middle' text-anchor='middle' fill='%23FFF' %3EA%3C/text%3E%3C/svg%3E)
Microsoft 365 e Office | Excel | Per la casa | Windows
Una famiglia di software per fogli di calcolo Microsoft con strumenti per l'analisi, la creazione di grafici e la comunicazione dei dati.
Ciao Salvatore,
se vuoi fare dei testo su questa nuova versione del file ti metto il link
Invio automatico e-mail promemoria excel 2019 #2.xlsm
Ti spiego l'approccio e vedi tu se ti sembra funzionale per le tue esigenze.
La particolarità è che nell'unica colonna di "check" (naturalmente per ogni data di scadenza dei documenti e corsi) viene inserita una stringa che rappresenta l'email per il termine mancante alla scadenza.
In particolare "6m" (scadenza entro 6 mesi o meno), "3m" (scadenza entro 3 mesi o meno), "1m" (scadenza entro 1 mese o meno) e "15g" (scadenza entro 15 giorni o meno).
Se ci si trova in uno di quei periodi e nella cella della check non è presente la relativa stringa verrà creata l'email.
Man mano che vengono inviate le email per i diversi tempi di scadenza la cella del "check" conterrà tutte le relative stringe separate da una virgola (6m,3m,1m,15g).
Il codice nel modulo1 è un po' cambiato.
Ho eliminato una costante (quella che serviva per impostare il periodo di tempo alla scadenza) visto che ora i periodi sono 4.
E un'altra costante, quella che inseriva la "X" nella cella della "check", è ora diventata una variabile all'intero della routine "CreaEmailScadenze".
Oltre al fatto che ho cambiato approccio per determinare quella che, prima, era la data di avviso.
Ora, per gestire i vari intervalli, ho dichiarato quattro variabili che, partendo dalla data di scadenza, e andando in dietro nel tempo, calcolano la date date che, confrontate con la data "odierna", verificano se mancano da 6 mesi fino a 3 mesi, poi da 3 mesi a 1 mese, da 1 mese a 15 giorni, e da 15 giorni in giù.
Questo il codice sempre presente in Modulo1 (riporto nuovamente tutto anche le parti non modificate):
Option Explicit
Public Const NDoc As Long = 2 '<=== in caso di aggiunta di nuovi documenti indicare qui il numero complessivo di documenti
Public Const NCorsi As Long = 11 '<=== in caso di aggiunta di nuovi corsi indicare qui il numero complessivo dei corsi
Public Const sNomeFoglioPC As String = "Pandettamento_Corsi" '<=== nome foglio dati pandettamento e corsi
Public Const sNomeTabellaPC As String = "TabellaPandettamentoCorsi" '<=== nome tabella dati pandettamento e corsi
Public Const bInviaEmailAutomaticamente As Boolean = False '<=== impostare True per invio immediato dell'email
'Public Const sStringaCheck As String = "X" '<=== se si volesse iserire un diverso carattere per il check modificare qui
Function oLoPC() As ListObject
Set oLoPC = ThisWorkbook.Worksheets(sNomeFoglioPC).ListObjects(sNomeTabellaPC)
End Function
Sub CreaEmailScadenze(Optional oLoRow As Variant)
Dim StartRow As Long
Dim oLoRows As Long
Dim i As Long, j As Long
Dim DataAvviso6m As Date
Dim DataAvviso3m As Date
Dim DataAvviso1m As Date
Dim DataAvviso15g As Date
Dim DataScadenza As Date
Dim sGrado As String
Dim sCognome As String
Dim sNome As String
Dim sEmail As String
Dim sTipoDocCorso As String
Dim sNomeDocCorso As String
Dim sStringaCheck As String
Dim sCheck As String
Dim bSendMail As Boolean
Dim sTempoMancante As String
Dim sTestoOggettoMail As String
Dim sTestoCorpoMail As String
With oLoPC
If IsMissing(oLoRow) Then
StartRow = 1
oLoRows = .ListRows.Count
Else
StartRow = oLoRow
oLoRows = oLoRow
End If
For i = StartRow To oLoRows
sGrado = .ListColumns("GRADO").DataBodyRange(i).Value
sCognome = .ListColumns("COGNOME").DataBodyRange(i).Value
sNome = .ListColumns("NOME").DataBodyRange(i).Value
sEmail = .ListColumns("POSTA ELETTRONICA").DataBodyRange(i).Value
For j = 1 To NDoc
bSendMail = False
DataScadenza = .ListColumns("DATA DI SCADENZA D" & j).DataBodyRange(i).Value
sTipoDocCorso = "documento"
sNomeDocCorso = .ListColumns("NUMERO D" & j).Range(1).Offset(-1).Value
sCheck = .ListColumns("CHECK D" & j).DataBodyRange(i).Value
If DataScadenza <> "00:00:00" Then
DataAvviso6m = DateAdd("M", -6, DataScadenza)
DataAvviso3m = DateAdd("M", -3, DataScadenza)
DataAvviso1m = DateAdd("M", -1, DataScadenza)
DataAvviso15g = DateAdd("D", -15, DataScadenza)
If Date >= DataAvviso6m And Date < DataAvviso3m Then
If InStr(1, sCheck, "6m") = 0 Then bSendMail = True
sStringaCheck = "6m"
sTempoMancante = "sei mesi"
ElseIf Date >= DataAvviso3m And Date < DataAvviso1m Then
If InStr(1, sCheck, "3m") = 0 Then bSendMail = True
sStringaCheck = "3m"
sTempoMancante = "tre mesi"
ElseIf Date >= DataAvviso1m And Date < DataAvviso15g Then
If InStr(1, sCheck, "1m") = 0 Then bSendMail = True
sStringaCheck = "1m"
sTempoMancante = "un mese"
ElseIf Date >= DataAvviso15g Then
If InStr(1, sCheck, "15g") = 0 Then bSendMail = True
sStringaCheck = "15g"
sTempoMancante = "quindici giorni"
End If
If bSendMail Then
sTestoOggettoMail = sGrado & " " & sCognome & " " & sNome & " - " & _
"Avviso scadenza " & sTipoDocCorso & " """ & sNomeDocCorso & _
""" con data scadenza " & DataScadenza
sTestoCorpoMail = "Egr. " & sGrado & " " & sCognome & " " & sNome & "," & Chr(10) & _
"si avvisa che per il " & sTipoDocCorso & " """ & sNomeDocCorso & _
"""con data scadenza " & DataScadenza & " mancano meno di " & sTempoMancante & " alla scadenza." & String(2, Chr(10)) & _
"Cordiali saluti"
Call CreaEmailHtml(sEmail, sTestoOggettoMail, sTestoCorpoMail, , , , bInviaEmailAutomaticamente)
If sCheck = "" Then
sCheck = sStringaCheck
Else
sCheck = sCheck & "," & sStringaCheck
End If
.ListColumns("CHECK D" & j).DataBodyRange(i).Value = sCheck
End If
End If
Next j
For j = 1 To NCorsi
bSendMail = False
DataScadenza = .ListColumns("SCADENZA C" & j).DataBodyRange(i).Value
sTipoDocCorso = "corso"
sNomeDocCorso = .ListColumns("ULTIMO C" & j).Range(1).Offset(-1).Value
sCheck = .ListColumns("CHECK C" & j).DataBodyRange(i).Value
If DataScadenza <> "00:00:00" Then
DataAvviso6m = DateAdd("M", -6, DataScadenza)
DataAvviso3m = DateAdd("M", -3, DataScadenza)
DataAvviso1m = DateAdd("M", -1, DataScadenza)
DataAvviso15g = DateAdd("D", -15, DataScadenza)
If Date >= DataAvviso6m And Date < DataAvviso3m Then
If InStr(1, sCheck, "6m") = 0 Then bSendMail = True
sStringaCheck = "6m"
sTempoMancante = "sei mesi"
ElseIf Date >= DataAvviso3m And Date < DataAvviso1m Then
If InStr(1, sCheck, "3m") = 0 Then bSendMail = True
sStringaCheck = "3m"
sTempoMancante = "tre mesi"
ElseIf Date >= DataAvviso1m And Date < DataAvviso15g Then
If InStr(1, sCheck, "1m") = 0 Then bSendMail = True
sStringaCheck = "1m"
sTempoMancante = "un mese"
ElseIf Date >= DataAvviso15g Then
If InStr(1, sCheck, "15g") = 0 Then bSendMail = True
sStringaCheck = "15g"
sTempoMancante = "quindici giorni"
End If
If bSendMail Then
sTestoOggettoMail = sGrado & " " & sCognome & " " & sNome & " - " & _
"Avviso scadenza " & sTipoDocCorso & " """ & sNomeDocCorso & _
""" con data scadenza " & DataScadenza
sTestoCorpoMail = "Egr. " & sGrado & " " & sCognome & " " & sNome & "," & Chr(10) & _
"si avvisa che per il " & sTipoDocCorso & " """ & sNomeDocCorso & _
"""con data scadenza " & DataScadenza & " mancano meno di " & sTempoMancante & " alla scadenza." & String(2, Chr(10)) & _
"Cordiali saluti"
Call CreaEmailHtml(sEmail, sTestoOggettoMail, sTestoCorpoMail, , , , bInviaEmailAutomaticamente)
If sCheck = "" Then
sCheck = sStringaCheck
Else
sCheck = sCheck & "," & sStringaCheck
End If
.ListColumns("CHECK C" & j).DataBodyRange(i).Value = sCheck
End If
End If
Next j
Next i
End With
End Sub
Sub CreaEmailHtml(sTo As String, _
sOggettoEmail As String, _
sTestoEmail As String, _
Optional sCC As String, _
Optional sCCN As String, _
Optional sAllegati As String, _
Optional bSendMail As Boolean = False)
Dim oOutlook As Object
Dim oMail As Object
Dim arrAllegati As Variant
Dim i As Long
Set oOutlook = CreateObject("Outlook.Application")
Set oMail = oOutlook.CreateItem(0)
With oMail
.BodyFormat = 2 'HTML
.Display
.To = Trim(sTo)
.cc = Trim(sCC)
.BCC = Trim(sCCN)
If .To = "" And _
.cc = "" And _
.BCC = "" Then
bSendMail = False
End If
.Subject = Trim(sOggettoEmail)
sTestoEmail = Replace(Trim(sTestoEmail), Chr(10), "<br>")
sTestoEmail = "<HTML><BODY><p style='font-family:Calibri;font-size:11pt'>" & sTestoEmail & "</p></BODY></HTML>"
.HTMLBody = sTestoEmail & .HTMLBody
.ReadReceiptRequested = True
.OriginatorDeliveryReportRequested = .ReadReceiptRequested
On Error Resume Next
If sAllegati <> "" Then
arrAllegati = Split(sAllegati, ";")
For i = 0 To UBound(arrAllegati)
.Attachments.Add Trim(arrAllegati(i))
If Err.Number <> 0 Then
MsgBox "L'allegato" & vbNewLine & Trim(arrAllegati(i)) & vbNewLine & _
"non è stato trovato!", vbExclamation, "Errore Allegato"
bSendMail = False
Err.Clear
End If
Next i
End If
On Error GoTo 0
If bSendMail Then .send
End With
Set oOutlook = Nothing
Set oMail = Nothing
End Sub
Fai dei test con i tuoi dati reali e aggiusta il testo delle email a piacimento.
Per come ho impostato io il testo ottengo delle email del genere:
Ciao
p.s. nelle colonne delle date di scadenza ho inserito quattro formattazioni condizionali con differenti sfondi a seconda di quanto manchi alla scadenza.
Vedi tu se mantenerle o modificarle.