Public Sub CheckAndSendMail2()
' Constante html de sauts de ligne
Const BR2 As String = "<BR><BR>"
' Plage entière et ligne sur lesquelles la macro travaillera
Dim rDatas As Range, rRow As Range
' Objets externes
Dim dicMails As Object, MailApp As Object, MailItem As Object
' Tableau des valeurs de la colonne parcourue
Dim Valeurs As Variant
' Compteurs de boucle
Dim i As Integer, j As Integer
' Adresse mail, nom de l'analyste et tableaux des noms de dossier à mettre à jour
Dim sMail As String, arrDossiers() As String, Phrase As String
Dim vAnalyste As Variant
'
' initialisation de la plage des données, et du tableau à parcourir
Set rDatas = Feuil2.Range("T_Dépassés[#Data]")
'
' le tableau contiendra les noms et adresses mails
Valeurs = rDatas.Columns(7).Resize(, 2).Value
'
' Récolter une liste d'items uniques des analystes et leur adresses mails
Set dicMails = CreateObject("scripting.dictionary")
For i = 1 To UBound(Valeurs): dicMails(Valeurs(i, 1)) = Valeurs(i, 2): Next
'
' Sortir si aucun email récupéré
If dicMails.count = 0 Then Exit Sub
'
' Parcourir le dictionaire
For Each vAnalyste In dicMails.keys
' Adresse mails, et nom analyste en cours
sMail = dicMails(vAnalyste)
'sAnalyste = dicMails.keys(i)
'
' initialisation des variables pour l'item parcouru
j = 0
Erase arrDossiers
'
' parcourir les lignes de rDatas
For Each rRow In rDatas.Rows
'
If rRow.Cells(1, 8) = sMail And IsDate(rRow.Cells(1, 6)) Then
' Voir s'il est réellement nécessaire de conserver ce test sur la date
' Normalement si la ligne est dans le tableau c'est qu'elle est à mettre à jour
If rRow.Cells(1, 6) - Date < -365 Then
' ajout du nom prénom des dossiers
j = j + 1
ReDim Preserve arrDossiers(1 To j)
arrDossiers(j) = rRow.Cells(1, 2) & " " & rRow.Cells(1, 3)
End If
End If
Next
If MailApp Is Nothing Then Set MailApp = CreateObject("Outlook.Application")
If j > 1 Then
Phrase = "Les " & j & " dossiers ci-dessous sont à mettre à jour/!\"
Else
Phrase = "Le dossier ci-dessous est à mettre à jour/!\"
End If
Set MailItem = MailApp.createItem(0)
With MailItem
.Subject = "/!\ " & vAnalyste & " - Dossier à mettre à jour /!\ "
.HtmlBody = "<HTML><BODY>" & _
"Bonjour " & vAnalyste & "," & BR2 & _
Phrase & BR2 & Join(arrDossiers, "<BR>") & BR2 & _
"</BODY></HTML>"
'.display
' .send
End With
' détruire la référence au mailItem
Set MailItem = Nothing
Next
' Détruire la référence à outlookApp
Set MailApp = Nothing
End Sub