[XL-2002] Concatener des cellules non vides pour faire liste d'envoi mail [Résolu]

[tchoutchou69]

Bonjour,

Malgré mes progrès en vba j ai toujours autant besoin de vous.
Voici le problème du jour.
J'ai un tableau qui a des adresses mail dans la colonne D. Sur la colonne F je met un x pour sélection tel ou tel personne.

Ensuite je fais une routine VBA pour ne sortir que les lignes avec des x:

Code :

1
2
3
4
5
Dim i As Long
For i = 0 To 20
   If Cells(i + 1, 6).Value = "x" Then _
      Cells(i + 1, 9).Value = Cells(i + 1, 4).Value
Next i

Jusque là ca va mais après j aimerai concaténer le résultat des cellules I non vide dans une cellules H15 avec une séparation ";" pour avoir une liste d'envoi par mail.

Help et merci d'avance

[sdispro]

Salut tchoutchou69,

ci un code maccro a essayer et qui fait ton besoin:

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Range("D1:E1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$D$1:$E$21").AutoFilter Field:=2, Criteria1:="<>"
    Range("D2:D21").Select
    Selection.Copy
    Sheets("SELECTION").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("C1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=CONCATENATE(RC[-2],R[1]C[-2],R[2]C[-2],R[3]C[-2],R[4]C[-2],R[5]C[-2],R[6]C[-2],R[7]C[-2],R[8]C[-2],R[9]C[-2],R[10]C[-2],R[11]C[-2],R[12]C[-2])"
    Range("C2").Select

A+ et bon courage

[patricktoulon]

bonjour

Code :

1
2
3
4
5
Dim i As Long
For i = 0 To 20
If Cells(i + 1, 6).Value = "x" Then _
Cells(i + 1, 9).Value = Cells(15, 9).Value  &";" & Cells(i + 1, 4).Value
Next i

au plaisir

[tchoutchou69]

Pour Sdisro : j ai un peu de mal à comprendre.

Pour patricktoulon : je suis arrivé à ce resultat mais apres j aimerais concatener les resultats des cellules non vides de la colonne H dans une cellule I

[issoram]

Ceci devrait faire l'affaire,

Code :

1
2
3
4
5
6
7
8
9
Dim i As Long
 
Cells(15, 8).Value = ""  'Ta cellule H15
For i = 0 To 20
    If Cells(i + 1, 6).Value = "x" Then
        Cells(i + 1, 9).Value = Cells(i + 1, 4).Value
        Cells(15, 8) = Cells(15, 8) & ";" & Cells(i + 1, 4).Value
    End If
Next i

Mais pourquoi ne pas utiliser plus simplement une formule en H15? Une piste pour cela ici: http://www.developpez.net/forums/d89...atener-a1-a23/

Cordialement.

[sdispro]

Re,

désolé, je suis nouveau et je ne sais pas trop comment utiliser les outils proposer par le forum.

utilise la fonction "do until" afin de boucler tous tes mails ressortis en colonne i.
Tu précède ta boucle par un tri et le tour est joué.

[tchoutchou69]

Envoyé par issoram

Ceci devrait faire l'affaire,

Code :

Mais pourquoi ne pas utiliser plus simplement une formule en H15? Une piste pour cela ici: http://www.developpez.net/forums/d89...atener-a1-a23/

Cordialement.

Merci c est exactement ca, ensuite comment faire un copier coller pour le mettre dans un mail? j'arrive a faire une macro avec mailto mais apres je n arrive pas a copier dans to:

[sdispro]

re,

Envoi un Mail: l'adresse est dans la cellule D1, le sujet dans la D2 et le texte dans la D3.

Voilà, tu as tout d'expliquer et tu devrais pouvoir avancer dans ton projet.

'Tester avec Outlook Express 5.

Code :

1
2
3
4
5
6
7
8
9
10
11
Sub EnvoiUnMail()
Dim MailAd As String
Dim Msg As String
Dim Subj As String
Dim URLto As String
MailAd = Range("d1")
Subj = Range("d2")
Msg = Msg & Range("d3")
URLto = "mailto:" & MailAd & "?subject=" & Subj & "&body=" & Msg
ActiveWorkbook.FollowHyperlink Address:=URLto
End Sub

Bonne fin d'AM

[tchoutchou69]

Aurais tu la meme chose mais pour ootlouk 2003?

[sdispro]

Re,

cela marche très bien pour outlook 2003.

Tu rencontres des problèmes avec ce code?

[tchoutchou69]

Super ca marche merci à vous deux. Je laisse le code de la macro pour ceux qui veulent.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Private Sub CommandButton1_Click()
 
Dim MailAd As String
Dim Msg As String
Dim Subj As String
Dim URLto As String
 
Range("H2:H16,H25").Select
    Range("H25").Activate
    Application.CutCopyMode = False
    Selection.ClearContents
'
Dim i As Long
For i = 0 To 20
   If Cells(i + 1, 6).Value = "x" Then _
      Cells(i + 1, 8).Value = Cells(i + 1, 4).Value
Next i
 
    Range("H21").Select
    Selection.Copy
    Range("H25").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
MailAd = Range("H25")
Subj = Range("H26")
Msg = Msg & Range("H27")
URLto = "mailto:" & MailAd & "?subject=" & Subj & "&body=" & Msg
ActiveWorkbook.FollowHyperlink Address:=URLto
 
End Sub