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

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

  • Traçage_TP.xlsm
    36.8 KB · Affichages: 19
Trier par date Trier par votes
laurent950

laurent950

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

laurent950

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

  • Traçage_TP (Modifié Autocad).xlsm
    44.8 KB · Affichages: 11
Dernière édition:
Vote positif 0 Vote négatif
laurent950

laurent950

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

  • Traçage_TP (Modifié Autocad Collection dans Module de Classe).xlsm
    51.8 KB · Affichages: 3
Dernière édition:
Vote positif 0 Vote négatif
Dranreb

Dranreb

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

laurent950

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

  • Traçage_TP (Modifié Autocad Collection dans Module de Classe bis).xlsm
    58.5 KB · Affichages: 3
Vote positif 0 Vote négatif

Discussions similaires

TheLio
  • Question
XL 2016 [VBA] Boucle sur cases à cocher et N° de ligne est décalée de 2
Réponses
6
Affichages
619
vgendron
vgendron
C
  • Question
XL 2021 case à cocher dans ListView impacte une cellule de feuille
Réponses
1
Affichages
771
fanch55
fanch55
M
  • 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
852
MONTREAL2020
M
S
  • Résolu(e)
Autres VBA pour copier une cellule à gauche de la cellule sélectionnée
Réponses
1
Affichages
2 K
sg394
S
R
  • Question
VBA ; recherche de valeurs mini sur une plage de façon dynamique
2 3
Réponses
30
Affichages
5 K
Raka
R
R
  • Question
Recherche de valeurs dans un tableau en VBA
Réponses
11
Affichages
10 K
Raka
R
R
  • Question
VBA - valeurs incrémentielles selon conditions
Réponses
0
Affichages
900
Raka
R
M
  • Résolu(e)
XL 2016 Message d'erreur aléatoire pour les utilisateurs réseau -Excel 2016
Réponses
11
Affichages
2 K
Melidan2006
M
M
  • Question
Centrer automatiquement un rectangle créé avec des bordures avec VBA
Réponses
7
Affichages
2 K
Matta
M
bellenm
  • Question
Gmail via CDO, attacher un fichier PDF, des adresses, un objet et un corps bien définit, code de Roland_M.
2 3
Réponses
43
Affichages
6 K
Roland_M
Roland_M

Membres actuellement en ligne

9 membres et 106 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 094
Messages
2 116 157
Membres
112 672
dernier inscrit
djudju