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

Etoto · 16 Novembre 2022

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 ?

sylvanu · 16 Novembre 2022

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 · 16 Novembre 2022

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.

Etoto · 16 Novembre 2022

sylvanu à dit:

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 · 16 Novembre 2022

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.

Etoto · 16 Novembre 2022

sylvanu à dit:
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 :
Regarde la pièce jointe 1155522
et [M3].Resize(UBound(Tablo), 1).Value = Application.Transpose(Tablo)
met se tableau dans la feuille à partir de la cellule M3.

Ok, super, merci pour l'explication.

yal · 16 Novembre 2022

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

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

Etoto

XLDnaute Barbatruc

Pièces jointes

sylvanu

sylvanu

XLDnaute Barbatruc

Pièces jointes

Etoto

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

Etoto

XLDnaute Barbatruc

yal

XLDnaute Occasionnel

Pièces jointes

Discussions similaires