Menu

Envoi en CC mail liste en colonne D sans doublons

Messages postés
86
Date d'inscription
jeudi 23 août 2012
Dernière intervention
27 novembre 2018
-
Bonjour,

J'ai récupéré, une macro qui me permet d'envoyer des mails à plusieurs utilisateurs, sans doublons ...
(mail utilisateurs en colonne c)

Je souhaite un complément de macro qui me permettrait de mettre en copie (cc), les responsables qui se trouvent en colonne D....

Merci d'avance !

Ma macro :

[/contents/446-fichier-sub Sub] filtre()
Dim plg As Range
Dim strbody As String
Dim fich As Variant
Dim ShT As Worksheet

fich = Application.GetOpenFilename("Tous les fichiers (*.xlsx),*.xlsx")
If fich = False Then Exit Sub

Workbooks.Open fich
Application.ScreenUpdating = False
With Sheets(1)
Sheets.Add
Set ShT = ActiveSheet
    'définition de la plage de données initiale
    Set plg = .Range("A4:l" & .Cells(Rows.Count, 1).End(xlUp).Row)
    'copie dans une colonne provisoire le nom des mails qu'il faudra creer/filtrer
    .[C:C].Copy .[O1]
    'supprime doublons
    .[O:O].RemoveDuplicates Columns:=Array(1), Header:=xlYes
    'utilisation de deux cellules provisoires une pour l'entete de recherche
    .[P1] = .[C4]
    
    'on passe en revu toutes les participations à dispo
    For i = 4 To .[O65536].End(xlUp).Row
    ShT.[A1].CurrentRegion.Delete
        'l'autre les participants à rechercher
        .[p2] = .Range("O" & i)
         
        'filtre avancé avec copie immédiate
        plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.[P1:P2], CopyToRange:=ShT.[A1]
        ShT.Range("A:l").EntireColumn.AutoFit
        ShT.Rows(1).Insert
        ShT.[A1] = ""
        
        strbody = "<b><font color=cornflowerblue>" & "<i>Bonjour,</i><p><i><font color=cornflowerblue></i>" & "<b><font color=cornflowerblue>" & "<p>Je vous prie de trouver ci-après, le récapitulatif de votre participation à XXXX!" & "<A href=" & "file://..........." & "<p>Délégation électronique à signer svp !</A>" & "<b><font color=cornflowerblue>" & RangetoHTML(ShT.Range("A1:l" & ShT.Cells(Rows.Count, 1).End(xlUp).Row)) & "<p>Bien cordialement,"
        EnvoiAutomatiqueMail strbody, .[p2]
    Next i
End With
ActiveWorkbook.Close False
End Sub


Public Sub EnvoiAutomatiqueMail(strbody As String, adresse As String)
Dim OutlookApp As Object
Dim OutlookMail As Object

Dim adresse2 As String
Dim message As String
Dim sujet As String

Dim i As Integer
Dim delegation As String
delegation = ""

        sujet = "Récapitulatif participation à XXXX + lien vers délégation électronique"
        Set OutlookApp = CreateObject("outlook.application")
        Set OutlookMail = OutlookApp.createitem(0)
            With OutlookMail
            .Subject = sujet 'sujet du mail
            .To = adresse 'adresse mail destinataire
            <bold>.cc =  'adresse mail manager
</bold>            .HTMLBody = strbody
            .Display 'affiche le mail
            '.send 'on envoie le mail créé
            End With
End Sub


Function RangetoHTML(rng As Range)
'
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
 
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function


EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI

Merci d'y penser dans tes prochains messages.


Merci d'y penser dans tes prochains messages.
Afficher la suite 

Votre réponse

1 réponse

Messages postés
300
Date d'inscription
mardi 5 juin 2018
Dernière intervention
17 décembre 2018
0
Merci
Bonjour,

Non testé : j'ai mis ci-dessous les deux macros que j'ai modifié. Chaque ligne modifiée est suivie de 3 astérisques. J'ai supposé que la liste des adresses des responsables commençait en D1 :

Sub filtre()
Dim plg As Range
Dim strbody As String
Dim fich As Variant
Dim ShT As Worksheet
Dim Copies As String '***
Dim C As Range '***

fich = Application.GetOpenFilename("Tous les fichiers (*.xlsx),*.xlsx")
If fich = False Then Exit Sub
  
Workbooks.Open fich
Application.ScreenUpdating = False
With Sheets(1)
  For Each C In .Range("D1", .Cells(.Rows.Count, 4).End(xlUp)) '***
    Copies = Copies & ";" & C.Value '***
  Next C '***
  Copies = Right(Copies, Len(Copies) - 1) '***
Sheets.Add
Set ShT = ActiveSheet
'définition de la plage de données initiale
Set plg = .Range("A4:l" & .Cells(Rows.Count, 1).End(xlUp).Row)
'copie dans une colonne provisoire le nom des mails qu'il faudra creer/filtrer
.[C:C].Copy .[O1]
'supprime doublons
.[O:O].RemoveDuplicates Columns:=Array(1), Header:=xlYes
'utilisation de deux cellules provisoires une pour l'entete de recherche
.[P1] = .[C4]

'on passe en revu toutes les participations à dispo
For i = 4 To .[O65536].End(xlUp).Row
ShT.[A1].CurrentRegion.Delete
'l'autre les participants à rechercher
.[p2] = .Range("O" & i)

'filtre avancé avec copie immédiate
plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.[P1:P2], CopyToRange:=ShT.[A1]
ShT.Range("A:l").EntireColumn.AutoFit
ShT.Rows(1).Insert
ShT.[A1] = ""

strbody = "<b><font color=cornflowerblue>" & "<i>Bonjour,</i><p><i><font color=cornflowerblue></i>" & "<b><font color=cornflowerblue>" & "<p>Je vous prie de trouver ci-après, le récapitulatif de votre participation à XXXX!" & "<A href=" & "file://..........." & "<p>Délégation électronique à signer svp !</A>" & "<b><font color=cornflowerblue>" & RangetoHTML(ShT.Range("A1:l" & ShT.Cells(Rows.Count, 1).End(xlUp).Row)) & "<p>Bien cordialement,"
EnvoiAutomatiqueMail strbody, .[p2], Copies
Next i
End With
ActiveWorkbook.Close False
End Sub

Public Sub EnvoiAutomatiqueMail(strbody As String, adresse As String, Copies As String) '***
Dim OutlookApp As Object
Dim OutlookMail As Object

Dim adresse2 As String
Dim message As String
Dim sujet As String

Dim i As Integer
Dim delegation As String
delegation = ""

sujet = "Récapitulatif participation à XXXX + lien vers délégation électronique"
Set OutlookApp = CreateObject("outlook.application")
Set OutlookMail = OutlookApp.createitem(0)
With OutlookMail
.Subject = sujet 'sujet du mail
.To = adresse 'adresse mail destinataire
.cc = Copies '***
.HTMLBody = strbody
.Display 'affiche le mail
'.send 'on envoie le mail créé
End With
End Sub


Daniel
PYGOS69
Messages postés
86
Date d'inscription
jeudi 23 août 2012
Dernière intervention
27 novembre 2018
-
Bonjour Daniel,

Merci pour L'évolution du script....

la liste des adresses des responsables commence en D5 (j'ai modifié...)

Comment procéder pour enlever les doublons comme pour la colonne C ?



Encore merci !
danielc0
Messages postés
300
Date d'inscription
mardi 5 juin 2018
Dernière intervention
17 décembre 2018
-
Sub filtre()
Dim plg As Range
Dim strbody As String
Dim fich As Variant
Dim ShT As Worksheet
Dim Copies As String '***
Dim C As Range '***
Dim Dico As Object '***

fich = Application.GetOpenFilename("Tous les fichiers (*.xlsx),*.xlsx")
If fich = False Then Exit Sub
  
Workbooks.Open fich
Application.ScreenUpdating = False
Set Dico = CreateObject("Scripting.Dictionary") '***
With Sheets(1)
  For Each C In .Range("D5", .Cells(.Rows.Count, 4).End(xlUp)) '***
    If Not Dico.exists(C.Value) Then Dico.Add C.Value, C.Value '***
  Next C '***
  For Each Item In Dico.items '***
    Copies = Copies & ";" & Item '***
  Next Item '***
  Copies = Right(Copies, Len(Copies) - 1) '***
Sheets.Add
Set ShT = ActiveSheet
'définition de la plage de données initiale
Set plg = .Range("A4:l" & .Cells(Rows.Count, 1).End(xlUp).Row)
'copie dans une colonne provisoire le nom des mails qu'il faudra creer/filtrer
.[C:C].Copy .[O1]
'supprime doublons
.[O:O].RemoveDuplicates Columns:=Array(1), Header:=xlYes
'utilisation de deux cellules provisoires une pour l'entete de recherche
.[P1] = .[C4]

'on passe en revu toutes les participations à dispo
For i = 4 To .[O65536].End(xlUp).Row
ShT.[A1].CurrentRegion.Delete
'l'autre les participants à rechercher
.[p2] = .Range("O" & i)

'filtre avancé avec copie immédiate
plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.[P1:P2], CopyToRange:=ShT.[A1]
ShT.Range("A:l").EntireColumn.AutoFit
ShT.Rows(1).Insert
ShT.[A1] = ""

strbody = "<b><font color=cornflowerblue>" & "<i>Bonjour,</i><p><i><font color=cornflowerblue></i>" & "<b><font color=cornflowerblue>" & "<p>Je vous prie de trouver ci-après, le récapitulatif de votre participation à XXXX!" & "<A href=" & "file://..........." & "<p>Délégation électronique à signer svp !</A>" & "<b><font color=cornflowerblue>" & RangetoHTML(ShT.Range("A1:l" & ShT.Cells(Rows.Count, 1).End(xlUp).Row)) & "<p>Bien cordialement,"
EnvoiAutomatiqueMail strbody, .[p2], Copies
Next i
End With
ActiveWorkbook.Close False
End Sub


Daniel
PYGOS69
Messages postés
86
Date d'inscription
jeudi 23 août 2012
Dernière intervention
27 novembre 2018
-
Merci !

Pour chaque participant , un mail doit être transmis à son responsable et non à tous les responsables ....

Le participant 1 reçoit dans son mail un récapitulatif = une invitation à signer la délégation électronique.

+ copie à son responsable

Le participant 2 reçoit dans son mail un récapitulatif = une invitation à signer la délégation électronique.

+ copie à son responsable

Cela fonctionne pour le récapitulatif avec le filtre mais pas pour le responsable...

Comment effectuer le filtre pour les responsables ?
danielc0
Messages postés
300
Date d'inscription
mardi 5 juin 2018
Dernière intervention
17 décembre 2018
-
Poste un classeur exemple.

Daniel
Commenter la réponse de danielc0