XL 2019 Boucle pour récupérer les valeurs de chaque case cocher

Tipeu · 14 Septembre 2020

Bonjour XLDnaute,

Auriez vous une solution a mon problème ci dessous :

J'ai actuellement mon fichier ci joint, qui a terme me permettrais de tracer des objets Cercle sous AutoCAD.
Pour cela j'aimerais que celui ci fonctionne en demandant a l'opérateur de cocher des cases sur le USF et que chaque case cocher renvoie les valeurs qui se situe en face des noms des cases par exemple si l'opérateur coche les cellules 1A, 2B et 3C, j'aimerais la macro récupere les donnes (-120, -207.8461 pour 1A / 0,0 pour 2B / 120, -207.8461 pour 3C) et que ces valeurs soit rempli automatiquement dans le morceau de code suivant :

VB:

CC(0) = Range("Valeur Centre X pour chaque case cocher"): CC(1) = Range ("Valeur Centre Y pour chaque case cocher")

Et que la macro le fasse au final en boucle pour chaque case cocher suivant la liste sur le USF avec le code suivant qui me permet de générer les objets cercles sur AutoCAD.

VB:

CC(0) = Range("C" & i): CC(1) = Range("D" & i)
'TEST CD(0) = CC(0): CD(1) = CC(1) - ("Valeur associer en colonne J suivant choix listbox1")

'Cercle
Set Cercle = AcadPlan.ModelSpace.AddCircle(CC, ComboBox1.Value)
Cercle.Color = Couleur
Cercle.LineWeight = Epaisseur
    'Détécteur
    Set Cercle = AcadPlan.ModelSpace.AddCircle(CD, 9.5)

Merci a tous.

laurent950 · 30 Novembre 2020

Bonjour,
J' ais corrigé ce code
Avec les parties Ajoutées ou Modifier de votre codes
Puis le Codes complet dans sont ensembles
La partie AUTOCAD m’intéresse aussi
cdt

BoiteDial (UserForm)

VB:

' Ajout
' Boucle sur les resultats pour test
    Dim i As Integer
    Dim Tresultat() As Variant
    Tresultat = CkxCln.TAcadCircleRes
    For i = LBound(Tresultat, 1) To UBound(Tresultat, 1)
        If Tresultat(i, 6) <> Empty Then
            Debug.Print "Centre x : " & Tresultat(i, 3) & " Centre x : " & Tresultat(i, 4) & " Code : " & Tresultat(i, 5)
'       Correction :
                CC(0) = Tresultat(i, 3): CC(1) = Tresultat(i, 4)
******************************************************************************************************** 
' Modification 
Private Sub CkxCln_Change(ByVal Nom As String, ByVal Etat As Boolean, ByVal CkxCln As CkxCollect)

CkxCollect (Module de Classe)

VB:

' Ajout
Private TabCircle() As Variant
Private Sub Class_Initialize()
    ' Tableau
        TabCircle = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 5))
            ReDim Preserve TabCircle(LBound(TabCircle, 1) To UBound(TabCircle, 1), LBound(TabCircle, 2) To UBound(TabCircle, 2) + 1)
End Sub
******************************************************************************************************
'Ajout
Property Let TAcadCircle(ByVal Nom As String, ByVal Test As Boolean)
Dim i As Integer
    For i = LBound(TabCircle, 1) To UBound(TabCircle, 1)
        If TabCircle(i, 5) = Nom Then
            If Test = True Then
                TabCircle(i, 6) = "x"
            Else
                TabCircle(i, 6) = ""
            End If
        End If
    Next i
End Property
Property Get TAcadCircleRes() As Variant()
    TAcadCircleRes = TabCircle
End Property
******************************************************************************************************
' Modification
Public Sub MéthodeRéservéeÀSupportCkx(ByVal Nom As String, ByVal Etat As Boolean, ByVal CkxCln As CkxCollect)
    RaiseEvent Change(Nom, Etat, CkxCln)
End Sub

SupportCkx (Module de Casse)

VB:

' Modification
Public Property Get Coché() As Boolean
    Coché = Ckx.Value
' Remplis le tableau = Vrai (x) ou Faux (Vide)
    Parent.TAcadCircle(Ckx.Caption) = Ckx.Value
End Property
Private Sub Ckx_Click()
    Parent.MéthodeRéservéeÀSupportCkx Ckx.Caption, Ckx.Value, Parent
End Sub

laurent950 · 30 Novembre 2020

Re,
Cela donne :
BoiteDial (UserForm)

VB:

Option Explicit
Private WithEvents CkxCln As CkxCollect
Private Sub ToggleButton1_Click()
Dim iNextPage As Long
       With Me.MultiPage1
           iNextPage = .Value + 1
           If iNextPage < .Pages.Count Then
               .Pages(iNextPage).Visible = True
               .Value = iNextPage
           End If
       End With
End Sub
Private Sub ToggleButton2_Click()
    Unload Me
End Sub
Private Sub ToggleButton3_Click()
Dim iNextPage As Long
       With Me.MultiPage1
           iNextPage = .Value - 1
           If iNextPage < .Pages.Count Then
               .Pages(iNextPage).Visible = True
               .Value = iNextPage
           End If
       End With
End Sub
Private Sub ToggleButton4_Click()
Dim iNextPage As Long
       With Me.MultiPage1
           iNextPage = .Value + 1
           If iNextPage < .Pages.Count Then
               .Pages(iNextPage).Visible = True
               .Value = iNextPage
           End If
       End With
End Sub
Private Sub ToggleButton5_Click()
    Unload Me
End Sub
Private Sub ToggleButton6_Click()
Dim iNextPage As Long
       With Me.MultiPage1
           iNextPage = .Value - 1
           If iNextPage < .Pages.Count Then
               .Pages(iNextPage).Visible = True
               .Value = iNextPage
           End If
       End With
End Sub
Private Sub ToggleButton7_Click()

'' Nécessite la référence Autocad xxx Type Library (Menu Outils > Références)
'    Dim AcadApp As AcadApplication, AcadPlan As AcadDocument
'' Création de l'objet AutoCAD dans Excel :
'        Set AcadApp = AcadApplication
'' Si ACAD n'est pas ouvert, il faut créer une nouvelle application comme si dessous :
'        Set AcadApp = New AcadApplication
'' Rend AutoCAD visible
'        AcadApp.Visible = True
'' Utilise le document ouvert :
'        Set AcadPlan = AcadApp.ActiveDocument

'' Définition des variables définissant la couleur et l'épaisseur du trait
'    Dim Couleur As AcColor
'    Dim Epaisseur As AcLineWeight
'' Définition de l'objet ligne
'    Dim Ligne As AcadLine
'' Définition de l'objet cercle
'    Dim Cercle As AcadCircle
'' Définition de la valeur de la couleur
'        Couleur = -7
'' Définition de l'épaisseur du trait
'        Epaisseur = 2

' Définition des variables des points composant les cercles :
    Dim CC(0 To 2) As Double
        Dim CD(0 To 2) As Double

' Définition des variables des points composant le contour :
    Dim Pori(0 To 2) As Double              ' Point origine
    Dim P1(0 To 2) As Double
    Dim P2(0 To 2) As Double
    Dim P3(0 To 2) As Double

' Boucle sur les resultats pour test
    Dim i As Integer
    Dim Tresultat() As Variant
    Tresultat = CkxCln.TAcadCircleRes
    For i = LBound(Tresultat, 1) To UBound(Tresultat, 1)
        If Tresultat(i, 6) <> Empty Then
            Debug.Print "Centre x : " & Tresultat(i, 3) & " Centre x : " & Tresultat(i, 4) & " Code : " & Tresultat(i, 5)
'       Correction :
                CC(0) = Tresultat(i, 3): CC(1) = Tresultat(i, 4)
'       Ci-dessous Ancien code :
'               CC(0) = Range("C" & i): CC(1) = Range("D" & i)
'                TEST CD(0) = CC(0): CD(1) = CC(1) - ("Valeur associer en colonne J suivant choix listbox1")
'       Autocad Fin de la correction
'                 Cercle
'                    Set Cercle = AcadPlan.ModelSpace.AddCircle(CC, ComboBox1.Value)
'                        Cercle.Color = Couleur
'                        Cercle.LineWeight = Epaisseur
'                 Détécteur
'                    Set Cercle = AcadPlan.ModelSpace.AddCircle(CD, 9.5)
'
'                 Définition des coordonnées des points lues dans Excel
'
'                 PLori1(0) = PCori2(0) -220: PLori1(1) = Pcori2 (1) -307.8461 'ou -100 si pas de ligne 1 choisis
'                 P2(0) = Cells(12, 4): P2(1) = Cells(12, 5)
'                 P3(0) = Cells(13, 4): P3(1) = Cells(13, 5)
        End If
'   Adapter la boucle For en Fonction du Process "AUTOCAD"
    Next i
'
'' Traçage du rectangle dans l'espace objet d'AutoCAD
'    Set Ligne = AcadPlan.ModelSpace.AddLine(Pori, P1) 'Traçage de la 1ere ligne
'        Ligne.Color = Couleur 'Donne la couleur choisie
'        Ligne.LineWeight = Epaisseur 'Donne l'épaisseur choisie
'' 2e ligne
'    Set Ligne = AcadPlan.ModelSpace.AddLine(P1, P2)
'        Ligne.Color = Couleur
'        Ligne.LineWeight = Epaisseur
'' 3e ligne
'    Set Ligne = AcadPlan.ModelSpace.AddLine(P2, P3)
'        Ligne.Color = Couleur
'        Ligne.LineWeight = Epaisseur
'' 4e ligne
'    Set Ligne = AcadPlan.ModelSpace.AddLine(P3, Pori)
'        Ligne.Color = Couleur
'        Ligne.LineWeight = Epaisseur
'
'' Libérer la mémoire des objets ouverts
'    Set Ligne = Nothing
'    Set AcadApp = Nothing
'    Set AcadPlan = Nothing
'
'' AcadPlan.Save 'Sauvegarde le dessin
'' AcadPlan.Close 'Ferme le dessin
'' AcadApp.Quit 'Ferme l'application AutoCAD

End Sub
Private Sub ToggleButton8_Click()
    Unload Me
End Sub
Private Sub UserForm_Initialize()

Set CkxCln = New CkxCollect
    CkxCln.Init Me.MultiPage1.Pages("Page2")
    CkxCln.Add "1A", 21.961525, 259.807625
    CkxCln.Add "3A", 21.961525, 155.884575
    CkxCln.Add "5A", 21.961525, 51.961525
    CkxCln.Add "2B", 51.961525, 207.8461
    CkxCln.Add "4B", 51.961525, 103.92305
    CkxCln.Add "6B", 51.961525, 0
    CkxCln.Add "1C", 81.961525, 259.807625
    CkxCln.Add "3C", 81.961525, 155.884575
    CkxCln.Add "5C", 81.961525, 51.961525
    CkxCln.Add "2D", 111.961525, 207.8461
    CkxCln.Add "4D", 111.961525, 103.92305
    CkxCln.Add "6D", 111.961525, 0
    CkxCln.Add "1E", 141.961525, 259.807625
    CkxCln.Add "3E", 141.961525, 155.884575
    CkxCln.Add "5E", 141.961525, 51.961525
    CkxCln.Add "2F", 171.961525, 207.8461
    CkxCln.Add "4F", 171.961525, 103.92305
    CkxCln.Add "6F", 171.961525, 0
    CkxCln.Add "1G", 201.961525, 259.807625
    CkxCln.Add "3G", 201.961525, 155.884575
    CkxCln.Add "5G", 201.961525, 51.961525
    CkxCln.Add "2H", 231.961525, 207.8461
    CkxCln.Add "4H", 231.961525, 103.92305
    CkxCln.Add "6H", 231.961525, 0
    CkxCln.Add "1I", 261.961525, 259.807625
    CkxCln.Add "3I", 261.961525, 155.884575
    CkxCln.Add "5I", 261.961525, 51.961525
    CkxCln.Add "2J", 291.961525, 207.8461
    CkxCln.Add "4J", 291.961525, 103.92305
    CkxCln.Add "6J", 291.961525, 0
    CkxCln.Add "1K", 321.961525, 259.807625
    CkxCln.Add "3K", 321.961525, 155.884575
    CkxCln.Add "5K", 321.961525, 51.961525
    CkxCln.Add "2L", 351.961525, 207.8461
    CkxCln.Add "4L", 351.961525, 103.92305
    CkxCln.Add "6L", 351.961525, 0
    CkxCln.Add "1M", 381.961525, 259.807625
    CkxCln.Add "3M", 381.961525, 155.884575
    CkxCln.Add "5M", 381.961525, 51.961525
    CkxCln.Add "2N", 411.961525, 207.8461
    CkxCln.Add "4N", 411.961525, 103.92305
    CkxCln.Add "6N", 411.961525, 0
   End Sub
Private Sub CkxCln_Change(ByVal Nom As String, ByVal Etat As Boolean, ByVal CkxCln As CkxCollect)
    If CkxCln.NbrCochés = 0 Then ListBox1.Clear: Exit Sub
        ListBox1.List = CkxCln.ListeDesCochés
        ListBox2.List = CkxCln.ListeDesCochés
    End Sub

CkxCollect (Module de Classe)

VB:

Option Explicit
Event Change(ByVal Nom As String, ByVal Etat As Boolean, ByVal CkxCln As CkxCollect)
Private Cln As New Collection
Private Cts As MSForms.Controls
Private TabCircle() As Variant
Private Sub Class_Initialize()
    ' Tableau
        TabCircle = Range(Cells(2, 1), Cells(Cells(65536, 1).End(xlUp).Row, 5))
            ReDim Preserve TabCircle(LBound(TabCircle, 1) To UBound(TabCircle, 1), LBound(TabCircle, 2) To UBound(TabCircle, 2) + 1)
End Sub
Public Sub Init(ByVal UFm As Object)
    Set Cln = New Collection
    Set Cts = UFm.Controls
End Sub
Property Let TAcadCircle(ByVal Nom As String, ByVal Test As Boolean)
Dim i As Integer
    For i = LBound(TabCircle, 1) To UBound(TabCircle, 1)
        If TabCircle(i, 5) = Nom Then
            If Test = True Then
                TabCircle(i, 6) = "x"
            Else
                TabCircle(i, 6) = ""
            End If
        End If
    Next i
End Property
Property Get TAcadCircleRes() As Variant()
    TAcadCircleRes = TabCircle
End Property
Public Sub Add(ByVal Nom As String, x As Double, ByVal Y As Double)
Dim SocleCkx As SupportCkx
Dim Ctl As MSForms.Control
    Set SocleCkx = New SupportCkx
    Set Ctl = Cts.Add("Forms.CheckBox.1")
        SocleCkx.Init Me, Ctl, Nom
        Cln.Add SocleCkx, Nom
        Ctl.Left = x: Ctl.Top = Y
End Sub
Public Function NbrCochés() As Long
Dim SCkx As SupportCkx
Dim T() As Variant
Dim N As Long
    For Each SCkx In Cln
        If SCkx.Coché Then
            NbrCochés = NbrCochés + 1
        End If
    Next SCkx
End Function
Public Function ListeDesCochés() As Variant()
Dim SCkx As SupportCkx
Dim T() As Variant
Dim N As Long
N = NbrCochés
    If N = 0 Then Exit Function
        ReDim T(1 To N, 1 To 1)
     N = 0
        For Each SCkx In Cln
            If SCkx.Coché Then N = N + 1: T(N, 1) = SCkx.Nom
        Next SCkx
ListeDesCochés = T
End Function
Public Sub MéthodeRéservéeÀSupportCkx(ByVal Nom As String, ByVal Etat As Boolean, ByVal CkxCln As CkxCollect)
    RaiseEvent Change(Nom, Etat, CkxCln)
End Sub

SupportCkx (Module de Casse)

VB:

Option Explicit
Private WithEvents Ckx As MSForms.CheckBox
Dim Parent As CkxCollect
Public Sub Init(ByVal It As CkxCollect, ByVal Ctl As MSForms.CheckBox, ByVal Caption As String)
    Set Parent = It
    Set Ckx = Ctl
        Ckx.Caption = Caption
   End Sub
Public Function Nom()
    Nom = Ckx.Caption
End Function
Public Property Get Coché() As Boolean
    Coché = Ckx.Value
' Remplis le tableau = Vrai (x) ou Faux (Vide)
    Parent.TAcadCircle(Ckx.Caption) = Ckx.Value
End Property
Private Sub Ckx_Click()
    Parent.MéthodeRéservéeÀSupportCkx Ckx.Caption, Ckx.Value, Parent
End Sub

Liens avec l'userform : Explication via se Fils

XL 2019 - Afficher les noms des checkbox sélectionné dans une listbox

Bonjour a tous, Je suis a la recherche d'une solution pour générer le nom de mes checkbox sélectionnés dans une liste box visible a coté en direct. Photo ci dessous : pour la démonstration j'ai cliqué sur ma checkbox nommé 1A j'aurais voulu que son nom apparaisse dans la listbox et si possible...

www.excel-downloads.com

laurent950 · 10 Décembre 2020

Bonsoir @Dranred

Comment faire Fonctionner la collection dans le module de classe !
Lié au résultat de la page 3 de L'UserForm avec le Module de Classe et la collection = Empty

Pour acceder a la Collection avec la boucle For Each

Impossible en passant directement avec Cln.

Conclusion il faut passer par une boucle For each pour accéder aux éléments de la Collections

Merci @Dranred

Dranreb · 10 Décembre 2020

Bonjour
Je ne veux pas qu'on utilise la collection pour le traçage.
Je veux qu'on explore une table des numéros de lignes des trous à tracer et qu'avec chacun d'eux on aille puiser les données dans un tableau unique (intégralement chagé en mémoire dès le début bien évidemment. Pas question de taper au coup par coup dans des cellules).

Dranreb · 10 Décembre 2020

Ce qui pourrait être fait c'est ça :

laurent950 · 10 Décembre 2020

Re @Dranred

Votre fichier est vraiment très bien réalisé, Merci @Dranred J'ai compris

laurent950 · 10 Décembre 2020

Re @Dranred

' Comment faire pour avoir les valeurs dans Cln (comme vous y arriv? dans Public Function NbrCoch?s() As Long)

J'y arrive pas je reposte le fichier avec la boucle For each
Public Function TracerCircle(ByVal Indc As Byte, ByVal Nom As String, ByVal Col As Long) As Double
Dim SCkx As SupportCkx
If Indc = 1 Then
For Each SCkx In Cln 'Cln est vide chez moi ?
If SCkx.Nom = Nom Then
TracerCircle = SCkx.Num
Exit Function
End If
Next SCkx
Else
For Each SCkx In Cln
If SCkx.Nom = Nom Then
TracerCircle = SCkx.Num
Exit Function
End If
Next SCkx
End If
End Function

Dranreb · 10 Décembre 2020

Encore une fois ce n'est pas dans la collection que je trouve les infos nécessaires au traçage, c'est dans le tableau TDon, aux numéros de lignes stockés dans TLgn.

laurent950 · 11 Décembre 2020

Bonjour @Dranred, @Tipeu

@Dranred j'ai abandonné cette idée de collection et j'ai suivie votre conseilles

@Tipeu à Tester

cdt

Tipeu · 18 Décembre 2020

Bonjour @laurent950,

Ci joint le fichier avec les données des tableaux màj.

laurent950 · 22 Décembre 2020

Re @Dranreb
je vous poste cette ébauche de module de classe avec la collection

Dranreb · 22 Décembre 2020

Encore ce truc mal foutu dès le départ …
Je ne veux pas m'en mêler.

XL 2019 Boucle pour récupérer les valeurs de chaque case cocher

Tipeu

XLDnaute Nouveau

Pièces jointes

laurent950

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

XL 2019 - Afficher les noms des checkbox sélectionné dans une listbox

Pièces jointes

laurent950

XLDnaute Barbatruc

Pièces jointes

Dranreb

XLDnaute Barbatruc

Dranreb

XLDnaute Barbatruc

Pièces jointes

laurent950

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

Pièces jointes

Dranreb

XLDnaute Barbatruc

laurent950

XLDnaute Barbatruc

Pièces jointes

Tipeu

XLDnaute Nouveau

Pièces jointes

laurent950

XLDnaute Barbatruc

Pièces jointes

Dranreb

XLDnaute Barbatruc

Discussions similaires