XL 2019 VBA - Copier liste de mail dans presse papier

im_Guillaume

XLDnaute Nouveau
Bonjour le forum,

Voici mon problème :
J'ai un tableau évolutif (des lignes vont être masquées par moment selon les volontés des utilisateurs) et je dois développer un code VBA qui permet de copier dans le presse papier la liste des email à l'écran.

L'idéal serait de les copier avec un séparateur ";" de façon à ce que l'utilisateur n'ai plus qu'à copier coller dans son envoi de mail.

Voilà mon code actuel qui ne fonctionne pas :

'Sub Selectmail()
'listemail = ""
'For Each c In Sheets("Feuil1").Range("J10").CurrentRegion.Cells(1)
' listemail = listemail & Sheets("Base de données").Cells(10, c).Value & ";"
' Next c
'
' Cells(10, Columns.Count) = listemail
' Cells(10, Columns.Count).Copy
'End Sub
'

Ci-joint le fichier.

Merci pour votre aide! :)
 

Pièces jointes

  • Forum_mail.xlsx
    13.4 KB · Affichages: 6
Solution
Bonjour Guillaume,
Un essai en PJ avec :
VB:
Sub Liste()
    Dim L%, listemail$
    listemail = ""
    For L = 11 To Range("J65500").End(xlUp).Row
        If Rows(L).Hidden = False Then
            listemail = listemail & Cells(L, "J") & ";"
        End If
    Next L
    Cells(9, "J") = Left(listemail, Len(listemail) - 1): Cells(9, "J").Copy
End Sub
NB: utilisez les balises </> pour le code, c'est beaucoup plus lisible.

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Guillaume,
Un essai en PJ avec :
VB:
Sub Liste()
    Dim L%, listemail$
    listemail = ""
    For L = 11 To Range("J65500").End(xlUp).Row
        If Rows(L).Hidden = False Then
            listemail = listemail & Cells(L, "J") & ";"
        End If
    Next L
    Cells(9, "J") = Left(listemail, Len(listemail) - 1): Cells(9, "J").Copy
End Sub
NB: utilisez les balises </> pour le code, c'est beaucoup plus lisible.
 

Pièces jointes

  • Forum_mail (1).xlsm
    17.3 KB · Affichages: 1

fanch55

XLDnaute Barbatruc
Bonjour à tous,
Une autre méthode sans cellule "tampon" :
VB:
Sub ListMail()
Dim First_Cell As Range, Last_Cell As Range, Cur_Cell As Range
    With Worksheets("Feuil1")
        Set First_Cell = .Cells.Find("Mail").Offset(1)
        If Not First_Cell Is Nothing Then
            Set Last_Cell = .Cells(.Rows.Count, First_Cell.Column).End(xlUp)
            For Each Cur_Cell In .Range(First_Cell, Last_Cell).SpecialCells(xlCellTypeVisible)
                List = List & Cur_Cell.Value & ";"
            Next
            With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                .SetText Trim(List): .PutInClipboard
            End With
            .Paste [J8] ' <-- pour vérif
        End If
    End With
    Application.CutCopyMode = False
End Sub
 

Discussions similaires

Réponses
6
Affichages
268

Statistiques des forums

Discussions
311 720
Messages
2 081 907
Membres
101 836
dernier inscrit
karmon