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

Etoto

XLDnaute Barbatruc
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

  • XLD.xlsm
    24.2 KB · Affichages: 6
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.

sylvanu

XLDnaute Barbatruc
Supporter XLD
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

  • XLD.xlsm
    23.8 KB · Affichages: 3

Etoto

XLDnaute Barbatruc
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.
Ha oui, comme je pensais, tout simple mais je comprenais pas. Merci beaucoup !
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
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 :
1668608182723.png

et [M3].Resize(UBound(Tablo), 1).Value = Application.Transpose(Tablo)
met se tableau dans la feuille à partir de la cellule M3.
 

yal

XLDnaute Occasionnel
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

  • XLD.xlsm
    24.7 KB · Affichages: 4

Discussions similaires

Statistiques des forums

Discussions
313 276
Messages
2 096 760
Membres
106 743
dernier inscrit
sshkm16