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

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion Tipeu
  • Date de début Date de début
  • Mots-clés Mots-clés
    vba

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
T

Tipeu

XLDnaute Nouveau
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.
 

Pièces jointes

Trier par date Trier par votes
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
 
Dernière édition:
Vote positif 0 Vote négatif
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
www.excel-downloads.com

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 www.excel-downloads.com
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
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
1607595312420.png


Impossible en passant directement avec Cln.
1607595396099.png


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

Merci @Dranred
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
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).
 
Vote positif 0 Vote négatif
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
 

Pièces jointes

Vote positif 0 Vote négatif
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

B
  • Question Question
XL 2016 Récupérer les valeurs de chaque titre à partir de plusieurs onglets
Réponses
4
Affichages
367
bnolwalid
B
Amigo
  • Question Question
XL 2019 Détecter les valeurs suivant les tableaux sélectionnés et, si elles sont non-existantes, les copier
2 3
Réponses
33
Affichages
1 K
Amigo
Amigo
C
  • Question Question
XL 2021 case à cocher dans ListView impacte une cellule de feuille
Réponses
1
Affichages
797
fanch55
fanch55
TheLio
  • Question Question
XL 2016 [VBA] Boucle sur cases à cocher et N° de ligne est décalée de 2
Réponses
6
Affichages
631
vgendron
vgendron
B
  • Résolu(e)
Microsoft 365 creation d'liste à imprimer
2 3 4
Réponses
51
Affichages
1 K
Banbara
B
Z
  • Résolu(e)
Microsoft 365 Problème de combinaison entre fonctions "If Then Else" et "SelectCase"
Réponses
11
Affichages
559
Zonmé
Z
Darkopsix
  • Résolu(e)
XL 2021 Récupérer des données de fichiers dons les noms sont renseignés dans des cellules
Réponses
2
Affichages
614
Darkopsix
Darkopsix
P
  • Question Question
Autres Condition SI sur google sheet
Réponses
4
Affichages
734
Polo94100
P
D
  • Question Question
Microsoft 365 VBA pour répéter - cacher 2 colonnes consécutives selon la valeur d'une cellule.
Réponses
4
Affichages
384
Didjo
D
P
  • Question Question
Google Sheets Probleme fonction SI avec case à cocher
Réponses
1
Affichages
1 K
Gégé-45550
Gégé-45550
L
  • Résolu(e)
Microsoft 365 Case à Cocher - VBA - Problème liaison de cellules
Réponses
5
Affichages
2 K
Hasco
Hasco
L
  • Résolu(e)
Microsoft 365 Pb de valeur de variable entre Sub
Réponses
5
Affichages
428
loreak
L
C
  • Question Question
XL 2013 [VBA]Créer un nombre de ligne en fonction d'un certain nombre de colonne et remplir ces lignes avec certaines valeurs
Réponses
6
Affichages
846
CaptainSalt31
C
N
  • Question Question
XL 2021 BESOIN D'aide macro
Réponses
7
Affichages
786
Gégé-45550
Gégé-45550
D
  • Question Question
XL 2016 Modification les valeurs d'une même colonne d'une ListBox dans USF
Réponses
5
Affichages
586
Damien0507
D
C
  • Résolu(e)
XL 2016 Ré-incrémentation ou réinitialisation de la valeur des cases d'option
2
Réponses
17
Affichages
2 K
Phil69970
Phil69970
M
  • Question Question
XL 2013 VBA-Envoyer par email "Plage de cellules collée dans un nouveau classeur en gardant formules de certaines cellules
Réponses
2
Affichages
869
MONTREAL2020
M
oguruma
Classe VBA pour gérer les paramètres d'une application
Réponses
3
Affichages
846
oguruma
oguruma
albuqs
  • Résolu(e)
XL 2016 Décompte de valeurs précises avec bornage
Réponses
11
Affichages
1 K
albuqs
albuqs
O
  • Résolu(e)
XL 2019 Moyenne de valeurs par date à partir d'un tableau
Réponses
4
Affichages
939
Olocsob
O
Retour