Liste selection multiple VBA

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

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:

job75

XLDnaute Barbatruc
Re : Liste selection multiple VBA

Re,

Pour répondre à votre post #15 :

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".

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

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.
 

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

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

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

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:

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

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:

Discussions similaires

Réponses
15
Affichages
648

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
312 765
Messages
2 091 892
Membres
105 084
dernier inscrit
lca.pertus