Envoi de mail lotus notes ien boucle via condition sous excel

LGGUESS Messages postés 8 Statut Membre -  
f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   -
Bonjour,

sur la base d'une liste excel , code , libellé code , adresse email, condition(colonne Q = " à revoir"
je souhaite adresser des mails via la macro jointe, en regroupant les codes et libellés d'une même adresse email sur le même envoi
le 1er mail fonctionne mais ma boucle ne marche pas
merci por votre aide

Liste
CODES VALEURS CATEGORIE Adresses Contacts à revoir
QS0003417027" GENEHABITAT 3 Loic.guessant@bnpparibas.com à revoir
FR0011043314 PACHA A1 FCPR bpanhard@galiena.fr à revoir
FR0011043322 PACHA A2 FCPR bpanhard@galiena.fr à revoir
FR0010086595 SIMIANE "D" Loic.guessant@bnpparibas.com à revoir
FR0010709493 ELITE LAS FCP basevaleur@rothschild.com à revoir

Macro

Sub Bouton416_Cliquer()
Dim Session As Object
Dim Dir As Object
Dim Doc As Object
Dim Workspace As Object
Dim EditDoc As Object
Dim LeTexte1 As String
Dim LeTexte2 As String
Dim LeTexteRelance As String
Dim resp As String
Dim nblignes As Integer

Sheets("INVENTAIRE").Select
Range("Q2").Select
Selection.End(xlDown).Select
nblignes = Selection.Rows
'ensuite il suffit de faire une boucle pour traiter les lignes
i = 2

For i = 2 To nblignes
'test de la colonne D
'Do While I <= nblignes

If Cells(i, 17).Value = "à revoir" Then
'Rows(i & ":" & i).Select
Cells(i, 1).Value
Cells.Select
Cells(i, 2).Value
Cells.Select

'Range(i, 3).Value
End If
Next i

LeTexte1 = "Bonjour," & vbCrLf & vbCrLf & "Nous vous remercions de bien vouloir nous communiquer les valorisations à fin de mois des valeurs jointes." _
& vbCrLf & vbCrLf & "L'information est à nous restituer à l'adresse DINAN GS REFERENTIEL VALEURS@bnpparibas.com:" _
& vbCrLf & vbCrLf & "Nous restons à votre disposition." & vbCrLf

LeTexte2 = Cells(i, 1).Value & Space(15) & Cells(i, 2).Value

Set Workspace = CreateObject("Notes.NotesUIWorkspace")
Set Session = CreateObject("notes.NOTESSESSION")
Set Dir = Session.GETDATABASE("", "")
Call Dir.OPENMAIL
Set Doc = Dir.CREATEDOCUMENT

Doc.form = "Memo"
Doc.Subject = "Demande"
Doc.SendTo = Cells(i, 5).Value
Doc.CopyTo = "Loic.guessant@bnpparibas.com"

Doc.Body = LeTexte1 & vbCrLf & LeTexte2 & vbCrLf & vbCrLf & vbCrLf & "Cordialement."

Doc.SaveMessageOnSend = True
Call Doc.Send(False)
Set Session = Nothing
MsgBox "Email sent.", vbOKOnly + vbInformation

Set Db = Nothing
Set Doc = Nothing
Set Workspace = Nothing
Set EditDoc = Nothing

End Sub

3 réponses

  1.
    f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
     
    Bonjour,

    a tester en adaptant les colonnes 

    Sub Bouton416_Cliquer()
    Dim Session As Object
    Dim Dir As Object
    Dim Doc As Object
    Dim Workspace As Object
    Dim EditDoc As Object
    Dim LeTexte1 As String
    Dim LeTexte2 As String
    Dim LeTexteRelance As String
    Dim resp As String
    Dim nblignes As Integer

    nblignes = Sheets("INVENTAIRE").Range("D2").End(xlDown).Row
    'ensuite il suffit de faire une boucle pour traiter les lignes
        LeTexte1 = "Bonjour," & vbCrLf & vbCrLf & "Nous vous remercions de bien vouloir nous communiquer les valorisations à fin de mois des valeurs jointes." _
                            & vbCrLf & vbCrLf & "L'information est à nous restituer à l'adresse DINAN GS REFERENTIEL VALEURS@bnpparibas.com:" _
                            & vbCrLf & vbCrLf & "Nous restons à votre disposition." & vbCrLf
    For i = 2 To nblignes
        With Sheets("INVENTAIRE")
            If .Cells(i, "E").Value = "à revoir" Then
                    LeTexte2 = .Cells(i, 1).Value & Space(15) & .Cells(i, 2).Value
                Set Workspace = CreateObject("Notes.NotesUIWorkspace")
                Set Session = CreateObject("notes.NOTESSESSION")
                Set Dir = Session.GETDATABASE("", "")
                    Call Dir.OPENMAIL
                Set Doc = Dir.CREATEDOCUMENT

                Doc.form = "Memo"
                Doc.Subject = "Demande"
                Doc.SendTo = .Cells(i, 5).Value
                Doc.CopyTo = "Loic.guessant@bnpparibas.com"
                Doc.Body = LeTexte1 & vbCrLf & LeTexte2 & vbCrLf & vbCrLf & vbCrLf & "Cordialement."
                Doc.SaveMessageOnSend = True
                    Call Doc.Send(False)
                Set Session = Nothing
                MsgBox "Email sent.", vbOKOnly + vbInformation
                Set Db = Nothing
                Set Doc = Nothing
                Set Workspace = Nothing
                Set EditDoc = Nothing
        End If
    Next i
End Sub
    0
    1. LGGUESS Messages postés 8 Statut Membre
       
      Merci pour cette proposition qui fonctionne.

      Il manque juste une évolution pour ne pas gêner les destinataires.

      En effet , il conviendrait de regrouper sur un même email tous les codes + libellés dont l'adresse email est identique

      Est-ce possible ?

      EXEMPLE :
      CODES VALEURS CATEGORIE Adresses Contacts à revoir
      QS0003417027" GENEHABITAT 3 Loic.guessant@bnpparibas.com à revoir
      FR0010086595 SIMIANE "D" Loic.guessant@bnpparibas.com à revoir
      FR0010709493 ELITE LAS FCP basevaleur@rothschild.com à revoir

      A nouveau merci pour cette évolution qui va m'être bien utile.
      0
  2. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
     
    Bonjour,

    adaptez les colonnes au besoin: 

    Sub Bouton416_Cliquer()
    Dim Session As Object
    Dim Dir As Object
    Dim Doc As Object
    Dim Workspace As Object
    Dim EditDoc As Object
    Dim LeTexte1 As String
    Dim LeTexte2 As String
    Dim LeTexteRelance As String
    Dim resp As String
    Dim nblignes As Integer
    Dim Dico_Adr As Object
    Dim PlageD, i, x, TMP, nb, Adr, lig

    'ensuite il suffit de faire une boucle pour traiter les lignes
        LeTexte1 = "Bonjour," & vbCrLf & vbCrLf & "Nous vous remercions de bien vouloir nous communiquer les valorisations à fin de mois des valeurs jointes." _
                            & vbCrLf & vbCrLf & "L'information est à nous restituer à l'adresse DINAN GS REFERENTIEL VALEURS@bnpparibas.com:" _
                            & vbCrLf & vbCrLf & "Nous restons à votre disposition." & vbCrLf
        'Numero unique pour numero de fichier CSV
    Set Dico_Adr = CreateObject("Scripting.Dictionary")
    With Sheets("INVENTAIRE")
        nblignes = Sheets("INVENTAIRE").Range("D2").End(xlDown).Row
        Set PlageD = .Range("D2:D" & nblignes)
        'boucle sur colonne C
        For i = 1 To PlageD.Count
            Dico_Adr(PlageD(i, 1)) = ""
        Next i
        'transfert adresses en tableau
        TMP = Dico_Adr.Keys 'Table sans doublon
    
        For i = 0 To UBound(TMP)
            If TMP(i) <> Empty Then
                Adr = TMP(i): LeTexte2 = ""
                nb = Application.CountIf(PlageD, Adr)
                If nb > 0 Then
                    If nb > 1 Then NL = vbNewLine Else NL = ""
                    For x = 1 To nb
                        lig = 1
                        lig = .Columns(4).Find(Adr, .Cells(lig, 4), , xlWhole).Row
                        If .Cells(lig, "E").Value = "à revoir" Then
                            LeTexte2 = LeTexte2 & .Cells(lig, 1).Value & Space(15) & .Cells(lig, 2).Value & NL
                        End If
                    Set Workspace = CreateObject("Notes.NotesUIWorkspace")
                    Set Session = CreateObject("notes.NOTESSESSION")
                    Set Dir = Session.GETDATABASE("", "")
                        Call Dir.OPENMAIL
                    Set Doc = Dir.CREATEDOCUMENT

                    Doc.form = "Memo"
                    Doc.Subject = "Demande"
                    Doc.SendTo = Adr
                    Doc.CopyTo = "Loic.guessant@bnpparibas.com"
                    Doc.Body = LeTexte1 & vbCrLf & LeTexte2 & vbCrLf & vbCrLf & vbCrLf & "Cordialement."
                    Doc.SaveMessageOnSend = True
                        Call Doc.Send(False)
                    Set Session = Nothing
                    MsgBox "Email sent.", vbOKOnly + vbInformation
                    Set Db = Nothing
                    Set Doc = Nothing
                    Set Workspace = Nothing
                    Set EditDoc = Nothing
                End If
            End If
        Next i
    End With
End Sub
    0
    1. LGGUESS Messages postés 8 Statut Membre
       
      Bonjour,

      Merci pour la réponse

      J'ai un souci "erreur de compilation" : End if sans bloc If
      0
    2. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717 > LGGUESS Messages postés 8 Statut Membre
       
      Re,

      comme je n'ai pas lotus, j'ai merdu en enlevant les lignes que j'avais mis pour tester 

      Sub Bouton416_Cliquer()
    Dim Session As Object
    Dim Dir As Object
    Dim Doc As Object
    Dim Workspace As Object
    Dim EditDoc As Object
    Dim LeTexte1 As String
    Dim LeTexte2 As String
    Dim LeTexteRelance As String
    Dim resp As String
    Dim nblignes As Integer
    Dim Dico_Adr As Object
    Dim PlageD, i, x, TMP, nb, Adr, lig

    'ensuite il suffit de faire une boucle pour traiter les lignes
        LeTexte1 = "Bonjour," & vbCrLf & vbCrLf & "Nous vous remercions de bien vouloir nous communiquer les valorisations à fin de mois des valeurs jointes." _
                            & vbCrLf & vbCrLf & "L'information est à nous restituer à l'adresse DINAN GS REFERENTIEL VALEURS@bnpparibas.com:" _
                            & vbCrLf & vbCrLf & "Nous restons à votre disposition." & vbCrLf
        'Numero unique pour numero de fichier CSV
    Set Dico_Adr = CreateObject("Scripting.Dictionary")
    With Sheets("INVENTAIRE")
        nblignes = Sheets("INVENTAIRE").Range("D2").End(xlDown).Row
        Set PlageD = .Range("D2:D" & nblignes)
        'boucle sur colonne C
        For i = 1 To PlageD.Count
            Dico_Adr(PlageD(i, 1)) = ""
        Next i
        'transfert adresses en tableau
        TMP = Dico_Adr.Keys 'Table sans doublon
    
        For i = 0 To UBound(TMP)
            If TMP(i) <> Empty Then
                Adr = TMP(i): LeTexte2 = ""
                nb = Application.CountIf(PlageD, Adr)
                If nb > 0 Then
                    If nb > 1 Then NL = vbNewLine Else NL = ""
                    For x = 1 To nb
                        lig = 1
                        lig = .Columns(4).Find(Adr, .Cells(lig, 4), , xlWhole).Row
                        If .Cells(lig, "E").Value = "à revoir" Then
                            LeTexte2 = LeTexte2 & .Cells(lig, 1).Value & Space(15) & .Cells(lig, 2).Value & NL
                        End If
                        Set Workspace = CreateObject("Notes.NotesUIWorkspace")
                        Set Session = CreateObject("notes.NOTESSESSION")
                        Set Dir = Session.GETDATABASE("", "")
                            Call Dir.OPENMAIL
                        Set Doc = Dir.CREATEDOCUMENT

                        Doc.form = "Memo"
                        Doc.Subject = "Demande"
                        Doc.SendTo = Adr
                        Doc.CopyTo = "Loic.guessant@bnpparibas.com"
                        Doc.Body = LeTexte1 & vbCrLf & LeTexte2 & vbCrLf & vbCrLf & vbCrLf & "Cordialement."
                        Doc.SaveMessageOnSend = True
                            Call Doc.Send(False)
                        Set Session = Nothing
                            MsgBox "Email sent.", vbOKOnly + vbInformation
                        Set Db = Nothing
                        Set Doc = Nothing
                        Set Workspace = Nothing
                        Set EditDoc = Nothing
                    Next i
                End If
            End If
    End With
End Sub
      0
    3. LGGUESS Messages postés 8 Statut Membre
       
      Encore merci

      mais j'ai un nouveau bug

      erreur de compilation

      référence de variable de contrôle incorrecte dans Next
      0
    4. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717 > LGGUESS Messages postés 8 Statut Membre
       
      Re, 


      Sub Bouton416_Cliquer()
    Dim Session As Object
    Dim Dir As Object
    Dim Doc As Object
    Dim Workspace As Object
    Dim EditDoc As Object
    Dim LeTexte1 As String
    Dim LeTexte2 As String
    Dim LeTexteRelance As String
    Dim resp As String
    Dim nblignes As Integer
    Dim Dico_Adr As Object
    Dim PlageD, i, x, TMP, nb, Adr, lig

    'ensuite il suffit de faire une boucle pour traiter les lignes
        LeTexte1 = "Bonjour," & vbCrLf & vbCrLf & "Nous vous remercions de bien vouloir nous communiquer les valorisations à fin de mois des valeurs jointes." _
                            & vbCrLf & vbCrLf & "L'information est à nous restituer à l'adresse DINAN GS REFERENTIEL VALEURS@bnpparibas.com:" _
                            & vbCrLf & vbCrLf & "Nous restons à votre disposition." & vbCrLf
        'Numero unique pour numero de fichier CSV
    Set Dico_Adr = CreateObject("Scripting.Dictionary")
    With Sheets("INVENTAIRE")
        nblignes = Sheets("INVENTAIRE").Range("D2").End(xlDown).Row
        Set PlageD = .Range("D2:D" & nblignes)
        'boucle sur colonne C
        For i = 1 To PlageD.Count
            Dico_Adr(PlageD(i, 1)) = ""
        Next i
        'transfert adresses en tableau
        TMP = Dico_Adr.Keys 'Table sans doublon
    
        For i = 0 To UBound(TMP)
            If TMP(i) <> Empty Then
                Adr = TMP(i): LeTexte2 = ""
                nb = Application.CountIf(PlageD, Adr)
                If nb > 0 Then
                    If nb > 1 Then NL = vbNewLine Else NL = ""
                    For x = 1 To nb
                        lig = 1
                        lig = .Columns(4).Find(Adr, .Cells(lig, 4), , xlWhole).Row
                        If .Cells(lig, "E").Value = "à revoir" Then
                            LeTexte2 = LeTexte2 & .Cells(lig, 1).Value & Space(15) & .Cells(lig, 2).Value & NL
                        End If
                    Next x
                    Set Workspace = CreateObject("Notes.NotesUIWorkspace")
                    Set Session = CreateObject("notes.NOTESSESSION")
                    Set Dir = Session.GETDATABASE("", "")
                        Call Dir.OPENMAIL
                    Set Doc = Dir.CREATEDOCUMENT

                    Doc.form = "Memo"
                    Doc.Subject = "Demande"
                    Doc.SendTo = Adr
                    Doc.CopyTo = "Loic.guessant@bnpparibas.com"
                    Doc.Body = LeTexte1 & vbCrLf & LeTexte2 & vbCrLf & vbCrLf & vbCrLf & "Cordialement."
                    Doc.SaveMessageOnSend = True
                        Call Doc.Send(False)
                    Set Session = Nothing
                    MsgBox "Email sent.", vbOKOnly + vbInformation
                    Set Db = Nothing
                    Set Doc = Nothing
                    Set Workspace = Nothing
                    Set EditDoc = Nothing
                End If
            End If
        Next i
    End With
End Sub
      0
    5. LGGUESS Messages postés 8 Statut Membre
       
      Bonjour,

      cette version n'est pas ok par rapport à la précédente
      voici le code qui permet d'adresser n mails qui fonctionne


      Sub Bouton416_Cliquer()
      Dim Session As Object
      Dim Dir As Object
      Dim Doc As Object
      Dim Workspace As Object
      Dim EditDoc As Object
      Dim LeTexte1 As String
      Dim LeTexte2 As String
      Dim LeTexteRelance As String
      Dim resp As String
      Dim nblignes As Integer



      nblignes = Sheets("INVENTAIRE").Range("Q2").End(xlDown).Row
      'ensuite il suffit de faire une boucle pour traiter les lignes
      LeTexte1 = "Bonjour," & vbCrLf & vbCrLf & "Nous vous remercions de bien vouloir nous communiquer les valorisations fin de mois des valeurs jointes." _
      & vbCrLf & vbCrLf & "L'information est à nous restituer par mail à l'adresse DINAN GS REFERENTIEL VALEURS@bnpparibas.com" _
      & vbCrLf & vbCrLf & "Nous vous en remercions et restons à votre disposition." & vbCrLf

      For i = 2 To nblignes
      With Sheets("INVENTAIRE")
      If .Cells(i, "Q").Value = "à revoir" And Cells(i, "P").Value = "mail" And Cells(i, "N").Value <> "Demande NF" Then


      LeTexte2 = .Cells(i, 1).Value & Space(15) & .Cells(i, 2).Value
      Set Workspace = CreateObject("Notes.NotesUIWorkspace")
      Set Session = CreateObject("notes.NOTESSESSION")
      Set Dir = Session.GETDATABASE("", "")
      Call Dir.OPENMAIL
      Set Doc = Dir.CREATEDOCUMENT

      Doc.form = "Memo"
      Doc.Subject = "Demande de valorisation fin de mois"


      Doc.SendTo = .Cells(i, 5).Value

      Doc.CopyTo = "Loic.guessant@bnpparibas.com"
      Doc.Body = LeTexte1 & vbCrLf & LeTexte2 & vbCrLf & vbCrLf & vbCrLf & "Cordialement."
      Doc.SaveMessageOnSend = True
      Call Doc.Send(False)
      Set Session = Nothing
      'MsgBox "Email sent.", vbOKOnly + vbInformation
      Set Db = Nothing
      Set Doc = Nothing
      Set Workspace = Nothing
      Set EditDoc = Nothing
      Cells(i, 14).Value = "Demande NF"
      End If
      End With

      Next i
      End Sub


      il manque juste le fait de regrouper les codes + libellés par adresse email pour ne faire qu'un envoi unique par adresse email

      CODES VALEURS Adresses Contacts adresse Revoir
      QS0003417027GENEHABITAT 3Loic.guessant@bnpparibas.com mail OK
      FR0011043314PACHA A1 FCPR alain.l.lucas@bnpparibas.com OK
      FR0011043322PACHA A2 FCPR alain.l.lucas@bnpparibas.com OK
      FR0010086595SIMIANE "D"Loic.guessant@bnpparibas.com mail à revoir
      FR0010086603SIMIANE "C"corinne.gautier@bnpparibas.com mail à revoir
      FR0010709493ELITE LAS FCP Loic.guessant@bnpparibas.com mail à revoir
      FR0010510834FIP Loic.guessant@bnpparibas.com OK
      FR0010590935FIP alain.l.lucas@bnpparibas.com OK
      FR0010672261GENCAP Loic.guessant@bnpparibas.com mail à revoir
      FR0010713958GENC AVENIR A alain.l.lucas@bnpparibas.com mail à revoir
      FR0010788984GENCAP PRIO A corinne.gautier@bnpparibas.com mail à revoir
      0
  3. f894009 Messages postés 17417 Date d'inscription   Statut Membre Dernière intervention   1 717
     
    Re,

    pas decide a faire ou vous ne connaissez pas ?????

    allez, essayez ca: 

    Sub Bouton416_Cliquer()
    Dim Session As Object
    Dim Dir As Object
    Dim Doc As Object
    Dim Workspace As Object
    Dim EditDoc As Object
    Dim LeTexte1 As String
    Dim LeTexte2 As String
    Dim LeTexteRelance As String
    Dim resp As String
    Dim nblignes As Integer
    Dim Dico_Adr As Object
    Dim PlageD, i, x, TMP, nb, Adr, lig

    'ensuite il suffit de faire une boucle pour traiter les lignes
        LeTexte1 = "Bonjour," & vbCrLf & vbCrLf & "Nous vous remercions de bien vouloir nous communiquer les valorisations à fin de mois des valeurs jointes." _
                            & vbCrLf & vbCrLf & "L'information est à nous restituer à l'adresse DINAN GS REFERENTIEL VALEURS@bnpparibas.com:" _
                            & vbCrLf & vbCrLf & "Nous restons à votre disposition." & vbCrLf
        'Numero unique pour numero de fichier CSV
    Set Dico_Adr = CreateObject("Scripting.Dictionary")
    With Sheets("INVENTAIRE")
        nblignes = Sheets("INVENTAIRE").Range("E2").End(xlDown).Row
        Set PlageD = .Range("E2:E" & nblignes)
        'boucle sur colonne C pour liste des adresses sans doublon
        For i = 1 To PlageD.Count
            Dico_Adr(PlageD(i, 1)) = ""
        Next i
        'transfert adresses en tableau
        TMP = Dico_Adr.Keys 'Table sans doublon
        'boucle sur liste adresses
        For i = 0 To UBound(TMP)
            If TMP(i) <> Empty Then     'adresse non vide
                Adr = TMP(i): LeTexte2 = ""
                'recherche combien de fois la meme adresse
                nb = Application.CountIf(PlageD, Adr)
                If nb > 0 Then
                    'si plus d'une fois meme adresse:
                    If nb > 1 Then NL = vbNewLine Else NL = ""
                    'boucle recherche position meme adresse pour regroupement Infos
                    For x = 1 To nb
                        lig = 1: lig = .Columns(5).Find(Adr, .Cells(lig, 5), , xlWhole).Row
                        If .Cells(lig, "Q").Value = "à revoir" And Cells(lig, "P").Value = "mail" And Cells(lig, "N").Value <> "Demande NF" Then
                            LeTexte2 = LeTexte2 & .Cells(lig, 1).Value & Space(15) & .Cells(lig, 2).Value & NL
                            .Cells(lig, 14).Value = "Demande NF"    'ecriture marqueur pour eviter envoi multiples
                        End If
                    Next x
                    'preparation envoi
                    Set Workspace = CreateObject("Notes.NotesUIWorkspace")
                    Set Session = CreateObject("notes.NOTESSESSION")
                    Set Dir = Session.GETDATABASE("", "")
                        Call Dir.OPENMAIL
                    Set Doc = Dir.CREATEDOCUMENT
                    Doc.form = "Memo"
                    Doc.Subject = "Demande de valorisation fin de mois"
                    Doc.SendTo = Adr
                    Doc.CopyTo = "Loic.guessant@bnpparibas.com"
                    Doc.Body = LeTexte1 & vbCrLf & LeTexte2 & vbCrLf & vbCrLf & vbCrLf & "Cordialement."
                    Doc.SaveMessageOnSend = True
                    Call Doc.Send(False)
                    Set Session = Nothing
                    'MsgBox "Email sent.", vbOKOnly + vbInformation
                    Set Db = Nothing
                    Set Doc = Nothing
                    Set Workspace = Nothing
                    Set EditDoc = Nothing
                End If
            End If
        Next i
    End With
End Sub
    0

Discussions similaires

Changer la couleur d'une cellule selon son texte
fantomex -
Picton -

5 réponses
Echec d'envoi message sur Messenger
Kris68 -
Colibri -

2 réponses
Rétrodiffusion "Mail Delivery System"
baissaoui -
baissaoui -

0 réponse