VBA : Copies plusieurs Cellules

Version imprimable

25/01/2022, 14h49
muzard

VBA : Copies plusieurs Cellules
Bonjour,
J'ai un tableau avec des adresses mails dans la colonne A (données verrouillées)
J'utilise une macro pour copier une adresse mail.

Par exemple, pour copier adresse mail en A1 je clique sur B1
Code:

1 2 3 Private Sub Worksheet_SelectionChange(ByVal Target As Range) ActiveCell.Offset(0, -1).Copy End Sub
Je souhaiterais pouvoir cliquer sur plusieurs cases afin de sélectionner plusieurs adresses mails de la liste espacées chacune d'un point-virgule (liste de diffusion personnalisée)
Comment modifier ma macro en ce sens ?

Merci pour vos retour

Aide

Bonjour

je propose de mettre des X dans une autre colonne et d'appliquer quelque chose du genre
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 Sub Bouton2_Cliquer() Dim mail As String Dim rng As Range: Set rng = Application.Range("Feuil3!A2:A5") Dim i As Integer For i = 2 To rng.Rows.Count + 1 'le +1 est là car A1 non présent dans rng If Range("B" & i).Value = "X" Then If i = 2 Then mail = Range("A" & i).Value Else mail = mail & " ; " & Range("A" & i).Value End If End If Next Range("B1").Value = mail End Sub
La ligne Set rng = Application.Range("Feuil3!A2:A5") est évidemment à adapter

Peut être quelqu'un d'autre pourra donner une solution sans mettre des x ailleurs

Salut

Je peux proposer un truc comme ça, même si personnellement, je ne trouve pas ça très "propre" ;)

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
32
33
34
35
36
37
38
Option Explicit
 
Private strListeDiffusion As String
 
 
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    'On vérifie que l'on se trouve dans la bonne colonne (peut-être amélioré si tu utilises un tableau structuré, en utilisant Intersect)
    If Target.Column = 1 Then
        'On vérifie que la cellule contient une adresse mail (la vérif peut-être améliorée...)
        If InStr(1, Target.Value, "@") <> 0 Then
            'On annule l'apparition du menu flottant
            Cancel = True
            'On vérifie que l'adresse n'est pas déjà dans la liste de diffusion
            If InStr(1, ";" & strListeDiffusion & ";", ";" & Target.Value & ";") = 0 Then
                'On regarde si un ";" doit être ajouté à la liste
                If strListeDiffusion <> "" Then strListeDiffusion = strListeDiffusion & ";"
                'On ajoute l'adresse mail à la liste de diffusion
                strListeDiffusion = strListeDiffusion & Target.Value
                'Option
                'On affiche la liste de diffusion dans une cellule
                Me.Range("A1").Value = strListeDiffusion
            End If
        End If
    End If
 
End Sub
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Column = 1 Then
        'On annule le double-click
        Cancel = True
        'On efface la liste de diffusion
        strListeDiffusion = ""
        'Option
        'On affiche la liste de diffusion dans une cellule
        Me.Range("A1").Value = strListeDiffusion
    End If
End Sub

Un clique droit sur l'adresse l'ajoute à la liste, un double clique vide la liste.
Tu récupères ensuite ta liste de diffusion dans la variable strListDiffusion pour faire ton mail et tu vide la variable (ainsi que la cellule A1 si tu as gardé l'option ;) )

++
Qwaz

03/02/2022, 17h12
muzard

2 pièce(s) jointe(s)

Hello,

Désolé pour cette réponse et ses remerciements tardifs à Fab et Qwaz pour leur proposition. ;)
J'ai adopté celle de Qwaz dans le classeur "tab1" et cela fonctionne parfaitement. :D

Bon, je vais faire mon difficile...
En fait, les adresses mails copiées sont sur deux colonnes et protégées pour que les utilisateurs ne fassent pas de bévues.
J'ai donc utilisé les colonnes adjacentes pour qu'ils puissent sélectionner les adresses. (classeur "tab2").

Mais je n'arrive pas à adapter ta macro pour que cela fonctionne. :?

Un dernier petit coup de main ?

Merci encore pour tout le temps passé sur ce forum et pour vos réponses.

Muzard

Salut

Tu peux essayer comme ça

Code:

1
2
3
4
5
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    'On vérifie que l'on se trouve dans la bonne colonne (peut-être amélioré si tu utilises un tableau structuré, en utilisant Intersect)
    If Target.Column = 2 Or Target.Column = 4 Then
        'On vérifie que la cellule contient une adresse mail (la vérif peut-être améliorée...)
        If InStr(1, Target.Offset(0, -1).Value, "@") <> 0 Then

++
Qwaz

04/02/2022, 11h19
muzard

Super
Après quelques tâtonnements, ça marche nickel ! Un grand grand merci Qwaz :D