Liste selection multiple VBA

M

Maud44

XLDnaute Junior
Bonjour
J'ai un problème, je n'arrive pas à mettre dans une cellule plusieurs données d'une même liste déroulante...Par exemple faire apparaitre A , B , C dans une même cellule ... en partant de la liste déroulante A, B , C ,D
Malgré les codes existants je ne comprends pas le fonctionnement du codE...
Quel code faut - il réaliser?
D'avance merci,
Cordialement,
 

Pièces jointes

  • Classeur1.xlsx
    28 KB · Affichages: 74
  • Classeur1.xlsx
    28 KB · Affichages: 75
  • Classeur1.xlsx
    28 KB · Affichages: 61
Trier par date Trier par votes
BOISGONTIER

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Re : Liste selection multiple VBA

Bonsoir,

Il n'y a pas besoin de colonne intermédiaire.

Cf Listes en cascade: choixs successifs


http://boisgontierjacques.free.fr/fichiers/DonneesValidation/DVChoixSuccessifs.xls
http://boisgontierjacques.free.fr/fichiers/DonneesValidation/DVChoixSuccessifs2.xls

Code: 
Choix successifs dans un menu 
les choix s'ajoutent ou se retranchent

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Address = "$C$2" And Target.Count = 1 Then
    Application.EnableEvents = False
    ValSaisie = Target
    Application.Undo
    p = InStr(Target, ValSaisie)
    If p > 0 Then
      Target = Left(Target, p - 1) & Mid(Target, p + Len(ValSaisie) + 1)
      If Right(Target, 1) = Chr(10) Then
        Target = Left(Target, Len(Target) - 1)
      End If
    Else
        If Target = "" Then
          Target = ValSaisie
        Else
          Target = Target & Chr(10) & ValSaisie
        End If
    End If
    Application.EnableEvents = True
 End If
End Sub

JB
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Liste selection multiple VBA

Re,

Pour répondre à votre post #15 :

Maud44 à dit:
Par contre, dans le cas du dernier message lorsqu'on clique sur un agent deux fois...le nom se met deux fois dans la cellule. Cependant je voudrais qu'il disparaisse. Une sorte de "cochage" et "décochage".
Cliquez pour agrandir...

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = Intersect(Target, Range("E2:E" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les événements
For Each r In r 'si plusieurs cellules sont modifiées
  With Cells(r.Row, "G")
    If CStr(r) = "" Then
      .Value = ""
    Else
      If InStr(.Text, CStr(r)) Then
        .Value = Replace(.Text, CStr(r) & vbLf, "")
        .Value = Replace(.Text, vbLf & CStr(r), "")
        .Value = Replace(.Text, CStr(r), "")
      Else
        .Value = .Text & IIf(.Text = "", "", vbLf) & CStr(r)
      End If
      r = .Value
    End If
    r.EntireRow.AutoFit 'ajustement de la hauteur
  End With
Next
Application.EnableEvents = True 'réactive les événements
End Sub
Fichier (4).

A+
 

Pièces jointes

  • Classeur diffusion(4).xls
    49.5 KB · Affichages: 100
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Liste selection multiple VBA

Re Jacques,

J'avais bien pensé à Application.Undo.

L'ennui c'est qu'il semble difficile de l'appliquer si plusieurs cellules sont modifiées ou effacées simultanément.

Avec la colonne auxiliaire pas de problème.

Bonne nuit.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Liste selection multiple VBA

Bonjour Maud44, JB, le forum,

Bon, même en modifiant plusieurs cellules on peut utiliser Application.Undo :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, c As Range, mem$(), i&
Set r = Intersect(Target, Range("E2:E" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les événements
ReDim mem(1 To r.Count)
Application.Undo 'annule l'entrée
For Each c In r 'si plusieurs cellules sont modifiées
  i = i + 1
  mem(i) = CStr(c) 'mémorisation
Next
Application.Undo 'restitue l'entrée
i = 0
For Each c In r
  i = i + 1
  If CStr(c) <> "" Then
    If InStr(mem(i), CStr(c)) Then
      mem(i) = Replace(mem(i), CStr(c) & vbLf, "")
      mem(i) = Replace(mem(i), vbLf & CStr(c), "")
      mem(i) = Replace(mem(i), CStr(c), "")
    Else
      mem(i) = mem(i) & IIf(mem(i) = "", "", vbLf) & CStr(c)
    End If
    c = mem(i)
  End If
Next
Application.EnableEvents = True 'réactive les événements
End Sub
Donc plus besoin de colonne auxiliaire.

Nota : finalement l'ajustement de la hauteur des lignes ne paraît pas nécessaire.

Fichier (5).

A+
 

Pièces jointes

  • Classeur diffusion(5).xls
    49.5 KB · Affichages: 45
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Liste selection multiple VBA

Re,

On aura peut-être remarqué quelques problèmes sur le fichier (5) si l'on supprime ou insère des lignes en colonne E.

Ce fichier (6) les évite :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, dercel As Range, derlig&, c As Range, mem$(), i&
Set r = Intersect(Target, Range("E2:E" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les événements
On Error Resume Next
Set dercel = Cells(Me.UsedRange.Row + Me.UsedRange.Rows.Count, "E")
ReDim mem(1 To r.Count)
Application.Undo 'annule l'entrée
derlig = dercel.Row
For Each c In r 'si plusieurs cellules sont modifiées
  i = i + 1
  mem(i) = CStr(c) 'mémorisation
Next
Application.Undo 'restitue l'entrée
If derlig = dercel.Row Then 'pas d'insertion/suppression de ligne
  i = 0
  For Each c In r
    i = i + 1
    If CStr(c) <> "" Then
      If InStr(mem(i), CStr(c)) Then
        mem(i) = Replace(mem(i), CStr(c) & vbLf, "")
        mem(i) = Replace(mem(i), vbLf & CStr(c), "")
        mem(i) = Replace(mem(i), CStr(c), "")
      Else
        mem(i) = mem(i) & IIf(mem(i) = "", "", vbLf) & CStr(c)
      End If
      c = mem(i)
    End If
  Next
End If
Application.EnableEvents = True 'réactive les événements
End Sub
A+
 

Pièces jointes

  • Classeur diffusion(6).xls
    46 KB · Affichages: 78
Vote positif 0 Vote négatif
M

Maud44

XLDnaute Junior
Re : Liste selection multiple VBA

Bonsoir,
Je reviens à l'attaque pour une question toute simple. Je voudrais appliquer le même code que dans le cellule E2 a la colonne F. Est ce que je peux mettre le code sous le premier code dans la feuille du code ?

Code que je veux mettre :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = Intersect(Target, Range("F2:F" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
Application.EnableEvents = False 'désactive les événements
For Each r In r 'si plusieurs cellules sont modifiées
With Cells(r.Row, "G")
If CStr(r) = "" Then
.Value = ""
Else
If InStr(.Text, CStr(r)) Then
.Value = Replace(.Text, CStr(r) & vbLf, "")
.Value = Replace(.Text, vbLf & CStr(r), "")
.Value = Replace(.Text, CStr(r), "")
Else
.Value = .Text & IIf(.Text = "", "", vbLf) & CStr(r)
End If
r = .Value
End If
r.EntireRow.AutoFit 'ajustement de la hauteur
End With
Next
Application.EnableEvents = True 'réactive les événements
End Sub
 

Pièces jointes

  • Michel DOSEQUI VF.xls
    93.5 KB · Affichages: 42
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Liste selection multiple VBA

Bonjour Maud44, le forum,

Je vais faire de la route aujourd'hui donc voici la macro qui traite les 2 colonnes E et F :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, adresse$, c As Range, mem$(), i&
Set r = Intersect(Target, [E:F], Rows("2:" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les événements
On Error Resume Next
ReDim mem(1 To r.Count)
Application.Undo 'annule l'entrée
adresse = r.Address
For Each c In r 'si plusieurs cellules sont modifiées
  i = i + 1
  mem(i) = CStr(c) 'mémorisation
Next
Application.Undo 'restitue l'entrée
If adresse <> r.Address Then GoTo 1 'si insertion/suppression de ligne
i = 0
For Each c In r
  i = i + 1
  If CStr(c) <> "" Then
    If InStr(mem(i), CStr(c)) Then
      mem(i) = Replace(mem(i), CStr(c) & vbLf, "")
      mem(i) = Replace(mem(i), vbLf & CStr(c), "")
      mem(i) = Replace(mem(i), CStr(c), "")
    Else
      mem(i) = mem(i) & IIf(mem(i) = "", "", vbLf) & CStr(c)
    End If
    c = mem(i)
  End If
Next
1 Application.EnableEvents = True 'réactive les événements
End Sub
C'est une adaptation de la macro du post #24.

Edit : j'ai revu le test pour l'insertion ou suppression de ligne.

Nota 1 : il ne fallait pas oublier de supprimer la colonne masquée G.

Nota 2 : curieuse idée de mettre des / dans la liste des agents !!

Fichier joint.

A+
 

Pièces jointes

  • Michel DOSEQUI VF(1).xls
    86 KB · Affichages: 45
Dernière édition:
Vote positif 0 Vote négatif
S

Si...

XLDnaute Barbatruc
Re : Liste selection multiple VBA

salut

pour accompagner job ;) un bout de chemin avant de bifurquer ...

Nota : j'ai pris l'évènement Clic/Droit car je n'arrive pas à gérer la rapidité des "clic / doubleclic" de mes souris malgré de nombreuses recherches et manipulations. Si... l'un d'entre vous a résolu ce problème, je le remercie par avance de la communication de la méthode.
 

Pièces jointes

  • Gestion Listes(VBA).xls
    67.5 KB · Affichages: 65
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : Liste selection multiple VBA

Re, salut Si...

Comme vous dites, faudrait peut-être "attaquer" Maud44 :rolleyes:

Les macros des posts #23 #24 #27 ont été testées sur Excel 2010.

Mais elles ne fonctionnent pas correctement sur Excel 2003.

Cette version (2) fonctionne sur toute version :

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim derlig&, r As Range, adresse$, c As Range, mem$(), i&
derlig = [E:F].Find("*", , xlValues, , xlByRows, xlPrevious).Row
Set r = Intersect(Target, Range("E2:F" & derlig))
If derlig < 2 Or r Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les événements
On Error Resume Next
ReDim mem(1 To r.Count)
Application.Undo 'annule l'entrée
adresse = r.Address
For Each c In r 'si plusieurs cellules sont modifiées
  i = i + 1
  mem(i) = CStr(c) 'mémorisation
Next
Application.Undo 'restitue l'entrée
If adresse <> r.Address Then GoTo 1 'si insertion/suppression de ligne
i = 0
For Each c In r
  i = i + 1
  If CStr(c) <> "" Then
    If InStr(mem(i), CStr(c)) Then
      mem(i) = Replace(mem(i), CStr(c) & vbLf, "")
      mem(i) = Replace(mem(i), vbLf & CStr(c), "")
      mem(i) = Replace(mem(i), CStr(c), "")
    Else
      mem(i) = mem(i) & IIf(mem(i) = "", "", vbLf) & CStr(c)
    End If
    c = mem(i)
  End If
Next
1 Application.EnableEvents = True 'réactive les événements
Application.ScreenUpdating = True
End Sub
Edit : ajouté à la fin Application.ScreenUpdating = True, c'est nécessaire si l'on fait du copier/coller.

A+
 

Pièces jointes

  • Michel DOSEQUI VF(2).xls
    87 KB · Affichages: 60
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

E
  • Question
Microsoft 365 Liste déroulante créée quand une cellule contient un texte spécifique
Réponses
10
Affichages
465
Erakmur
E
J
  • Question
Autres [Google Sheets] Recherchev, index, equiv sur liste déroulante - A l'aide !
Réponses
2
Affichages
439
Jaykerz
J
richardlion
  • Question
XL 2016 lien avec liste déroulante
Réponses
2
Affichages
277
richardlion
richardlion
A
  • Résolu(e)
Microsoft 365 Vider des listes déroulantes en cascade
Réponses
6
Affichages
417
Franc58
F
N
  • Résolu(e)
XL 2021 Menu deroulant
2
Réponses
15
Affichages
670
naudar
N
petitbuzuc
  • Question
XL 2016 Aide pour maj auto de la date + selection multiple dans une liste déroulante
Réponses
5
Affichages
322
fanch55
fanch55
Z
  • Question
XL 2016 RECHERCHEV et double liste de choix
Réponses
2
Affichages
405
zendb
Z
S
  • Question
Microsoft 365 Extraire une donnée majoritaire parmi une liste selon condition
Réponses
3
Affichages
307
scanx
S
W
  • Question
XL 2019 adapter image à liste déroulante dans tableau
Réponses
2
Affichages
384
wasate
W
J
  • Résolu(e)
XL 2013 Liste déroulante et sélection de cellule
Réponses
2
Affichages
444
Jean_Valjean
J

Membres actuellement en ligne

19 membres et 302 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 967
Messages
2 094 030
Membres
105 920
dernier inscrit
SAUSSARd