Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Microsoft 365 Code VBA qui renvoie une matrice à partir d'un liste à cocher au lieu d'une cellule

Créer une discussion
  • Initiateur de la discussion Initiateur de la discussion Etoto
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire

Etoto

XLDnaute Barbatruc
Supporter XLD
Hello à tous,

J'ai trouvé un super code sur se site internet mais j'aimerais l'adapter à ma situation. Le voici :


VB: 
Sub Rectangle1_Click()
'Updated by Extendoffice 20200730
Dim xSelShp As Shape, xSelLst As Variant, I, J As Integer
Dim xV As String
Set xSelShp = ActiveSheet.Shapes(Application.Caller)
Set xLstBox = ActiveSheet.ListBox1
If xLstBox.Visible = False Then
    xLstBox.Visible = True
    xSelShp.TextFrame2.TextRange.Characters.Text = "Pickup Options"
    xStr = ""
    xStr = Range("ListBoxOutput").Value
  
    If xStr <> "" Then
         xArr = Split(xStr, ";")
    For I = xLstBox.ListCount - 1 To 0 Step -1
        xV = xLstBox.List(I)
        For J = 0 To UBound(xArr)
            If xArr(J) = xV Then
              xLstBox.Selected(I) = True
              Exit For
            End If
        Next
    Next I
    End If
Else
    xLstBox.Visible = False
    xSelShp.TextFrame2.TextRange.Characters.Text = "Select Options"
    For I = xLstBox.ListCount - 1 To 0 Step -1
        If xLstBox.Selected(I) = True Then
        xSelLst = xLstBox.List(I) & ";" & xSelLst
        End If
    Next I
    If xSelLst <> "" Then
        Range("ListBoxOutput") = Mid(xSelLst, 1, Len(xSelLst) - 1)
    Else
        Range("ListBoxOutput") = ""
    End If
End If
End Sub

Comme vous le voyez ci-joint, quand j'appuie sur le rectangle bleu, une liste apparait, il me suffit de cocher les bons éléments et ils sont tous renvoyés sur la même cellule. C'est parfait mais je souhaiterais que cela se renvoie sous format d'une plage. Cela doit être tout bête à faire car je sais que dans ce code, y a de toute façon un endroit qui convertit la plage en une seul cellule, mais j'arrive pas à repérer quoi.

Pourriez-vous m'aider svp ?
 

Pièces jointes

Dernière édition:
Solution
Bonjour Etoto,
J'ai supprimé cette partie :
VB: 
    'If xSelLst <> "" Then
    '    Range("ListBoxOutput") = Mid(xSelLst, 1, Len(xSelLst) - 1)
    'Else
    '    Range("ListBoxOutput") = ""
    'End If
et remplacé par :
Code: 
    Tablo = Split(xSelLst, ";")
    [M3].Resize(UBound(Tablo), 1).Value = Application.Transpose(Tablo)
Voir PJ.
Trier par date Trier par votes
Bonjour Etoto,
J'ai supprimé cette partie :
VB: 
    'If xSelLst <> "" Then
    '    Range("ListBoxOutput") = Mid(xSelLst, 1, Len(xSelLst) - 1)
    'Else
    '    Range("ListBoxOutput") = ""
    'End If
et remplacé par :
Code: 
    Tablo = Split(xSelLst, ";")
    [M3].Resize(UBound(Tablo), 1).Value = Application.Transpose(Tablo)
Voir PJ.
 

Pièces jointes

Vote positif 0 Vote négatif
Solution
Ha oui, comme je pensais, tout simple mais je comprenais pas. Merci beaucoup !
 
Vote positif 0 Vote négatif
Split "découpe" une chaine via un séparateur et le met dans un tableau. Par ex :
Tablo = Split(xSelLst, ";") va découper la chaine "Lolo;Marco;Toto;" en un tableau :

et [M3].Resize(UBound(Tablo), 1).Value = Application.Transpose(Tablo)
met se tableau dans la feuille à partir de la cellule M3.
 
Vote positif 0 Vote négatif
Ok, super, merci pour l'explication. 🙂
 
Vote positif 0 Vote négatif
Bonjour
Presque rien à changer.

VB: 
Sub Rectangle1_Click()
'Updated by Extendoffice 20200730
Dim xSelShp As Shape, xSelLst As Variant, I, J As Integer
Dim xV As String

Dim tmp As Variant ' tableau provisoire

Set xSelShp = ActiveSheet.Shapes(Application.Caller)
Set xLstBox = ActiveSheet.ListBox1
If xLstBox.Visible = False Then
    xLstBox.Visible = True
    xSelShp.TextFrame2.TextRange.Characters.Text = "Pickup Options"
    xStr = ""
    xStr = Range("ListBoxOutput").Value
  
    If xStr <> "" Then
         xArr = Split(xStr, ";")
    For I = xLstBox.ListCount - 1 To 0 Step -1
        xV = xLstBox.List(I)
        For J = 0 To UBound(xArr)
            If xArr(J) = xV Then
              xLstBox.Selected(I) = True
              Exit For
            End If
        Next
    Next I
    End If
Else
    xLstBox.Visible = False
    xSelShp.TextFrame2.TextRange.Characters.Text = "Select Options"
    For I = xLstBox.ListCount - 1 To 0 Step -1
        If xLstBox.Selected(I) = True Then
        xSelLst = xLstBox.List(I) & ";" & xSelLst
        End If
    Next I
    If xSelLst <> "" Then
      Range("M:M").ClearContents ' Nettoyage de la zone de résultat
      tb = Split(Left(xSelLst, Len(xSelLst) - 1), ";") ' Transfert de la liste dans le tableau
      Range("M3").Resize(UBound(tb) + 1) = Application.Transpose(tb) ' Ecriture du résultat
    Else
        Range("ListBoxOutput") = ""
    End If
End If
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
192
patricktoulon
C
  • Question Question
XL 2016 VBA - Mettre en Indice une partie du contenu d'une cellule : problème avec la propriété Font.Subscript
Réponses
2
Affichages
69
crocrocro
C
C
  • Résolu(e)
XL 2021 VBA : Afficher plusieurs résultats d'une boucle dans une cellule
Réponses
3
Affichages
172
Claudinedu13
C
  • Question Question
Microsoft 365 Méthode Evaluate pour se dispenser d'une boucle imbriquée
Réponses
14
Affichages
377
patricktoulon
P
  • Résolu(e)
XL 2013 EXCEL VBA
Réponses
2
Affichages
351
pangasoul
P
N
  • Résolu(e)
Microsoft 365 Recherche dans un tableau structuré à partir d'une TextBox
Réponses
11
Affichages
365
NONO14
N
G
  • Question Question
Microsoft 365 Export données
Réponses
4
Affichages
482
GClaire
G
  • Résolu(e)
Microsoft 365 Problème de formatage de dates au format EUR
Réponses
2
Affichages
52
R1-
  • Question Question
XL 2010 Code de l'IA à corriger
2 3
Réponses
33
Affichages
2 K
cathodique
M
  • Résolu(e)
XL 2021 PUBLIPOSTAGE : Mise en forme du corps de message issu d'une cellule excel (VBA)
Réponses
4
Affichages
420
Minus&Cortex
M
M
  • Question Question
XL 2010 Aide à la suppression d'un produit en double dans un magasin spécifique avec conditions
Réponses
9
Affichages
761
Mody200
M
  • Question Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
569
AtTheOne
F
  • Question Question
Microsoft 365 aide VBA excel
Réponses
4
Affichages
332
Oneida
S
  • Résolu(e)
Microsoft 365 VBA Match: comment éviter l'erreur?
2
Réponses
29
Affichages
481
Dranreb
C
  • Question Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
394
CathyLD
C
  • Résolu(e)
Microsoft 365 VBA - BeforeDoubleClick, 1ère cellule vide à partir de cellule active pour insertion de ligne
Réponses
4
Affichages
174
AlCapone
S
  • Question Question
XL 2016 Problème dans la création d'une liste
Réponses
2
Affichages
344
Stéphane_1
S
M
  • Question Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
371
Gégé-45550
S
  • Résolu(e)
XL 2019 Problème de remplissage cellule en vba
Réponses
5
Affichages
373
snoopy07
S
E
  • Question Question
Microsoft 365 Listbox avec plus de 10 colonnes
Réponses
6
Affichages
506
Excellearning
E
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…