Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2010 Dupliquer une sub

Créer une discussion

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
C

Cmoiceli

XLDnaute Nouveau
Bonsoir,

Ca fait un moment que je cherche une solution alors je me décide à vous solliciter.

Voilà, j'aimerai automatiser car j'ai 300 labels sur une feuille et j'aimerai récupérer leur position en cliquant dessus.
J'aimerais autant ne pas avoir à copier et changer 300 fois mon code 😝 A force de farfouiller, j'ai récupéré un code qui semble devoir faire ce que je souhaite, sauf que ça ne fonctionne pas 😢

Sub NouvelleMacroBouton()
Set nouveaumodule = ActiveWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule)
nouveaumodule.Name = "TousLesLabels"
Dim i As Integer
For i = 300 To 1 Step -1
nouveaumodule.CodeModule.InsertLines 1, "Sub Label" & i & "_Click()"
nouveaumodule.CodeModule.InsertLines 2, "'Cells(3,1) = PositionLabel" & i.TopLeftCell.Address
nouveaumodule.CodeModule.InsertLines 7, "end sub"
Next i
End Sub

j'obtiens le message (vbext_ct_StdModule) variable non définie

Mon but n'est pas forcément de créer un nouveau module, mais de savoir déclarer "nouveaumodule" pour que ça fasse le job

précision : Je ne m'y connais absolument pas en code, je n'ai jamais appris mais j'aime essayer de trouver des solutions alors je bidouille mais là, je sèche 😅

merci de votre aide 🙂
 
Trier par date Trier par votes
Bonjour @Cmoiceli , @TooFatBoy , le forum,

@TooFatBoy : D'accord avec toi.

@Cmoiceli : En cette journée fériée, personnellement je ne me sens pas dispo pour faire un fichier avec 300 labels à ta place. Pourquoi n'as-tu pas joint ton fichier?

Bonne journée.

Edit: Bonjour @job75

@Cmoiceli : Autant pour moi, j'ai lu ta discussion et répondu avant de prendre mon café. Il faut activé la bibliothèque Microsoft visual basic for applications extensibility 5.3 ou bien remplacer vbext_ct_StdModule par 1. Comme spécifier sur ce lien
 
Dernière édition:
Vote positif 0 Vote négatif
Bonjour et déjà, merci beaucoup à vous

Je vais essayer de voir ce que j'arrive à faire avec votre exemple et je vous tiens au courant 🙂

En fait, je m'amuse avec Excel à essayer de trouver des fonctionnements pour certaines choses. ca n'a absolument rien de pro, je n'ai jamais appris à coder mais j'aime faire des petits utilitaires... a ma sauce . Je n''ai jamais pris un cours de VBA. Donc j'arrive à me familiariser avec petit à petit mais beaucoup de choses restent obscures
Je suis certaine que c'est très bancal, mais je me pose un challenge et j'essaie de trouver des solutions. Il y a surement plus simple, moins tordu, mais je ne vous demanderai jamais de coder à ma place ! Je me pose un challenge, je trouve un chemin et j'essaie de le suivre jusqu'au bout.

si ca vous intéresse, le pourquoi de mes 300 labels : là j'ai un tableau à 2 entrées et je veux que lorsque je clique sur la case correspondante, j'ai la possibilité de lui donner une couleur au choix entre 4.
la solution (surement tordue) que j'ai trouvé :
j'ai lié un label dans chaque case (sans caption)
je récupère son adresse dans une case de ma feuille pour pouvoir agir dessus
quand je clique sur mon label, j'ouvre un useform avec 4 boutons de couleur
quand je choisi une couleur, une valeur est entrée dans la case et mon label prend bien la couleur choisie

Je suis assez contente d'avoir réussi déjà à faire ça et oui, j'ai 32 lignes et 20 colonne : ca fait même 640 labels
et je suis cap de passer le temps qu'il faut à tous les écrire 1 par 1 si je n'ai pas de solution XP

profitez bien de ce jour férié 😉
 
Vote positif 0 Vote négatif
Merci pour vos explications, voyez ce fichier (2) avec le code du module de classe :
VB: 
Public WithEvents LB As MSForms.Label

Private Sub LB_Click()
UserForm1.Caption = "Couleur " & LB.Name
UserForm1.Show
End Sub
et le code de l'UserForm :
VB: 
Private Sub Label1_Click()
Feuil1.OLEObjects(Mid(Me.Caption, 9)).Object.BackColor = Label1.BackColor
End Sub

Private Sub Label2_Click()
Feuil1.OLEObjects(Mid(Me.Caption, 9)).Object.BackColor = Label2.BackColor
End Sub

Private Sub Label3_Click()
Feuil1.OLEObjects(Mid(Me.Caption, 9)).Object.BackColor = Label3.BackColor
End Sub

Private Sub Label4_Click()
Feuil1.OLEObjects(Mid(Me.Caption, 9)).Object.BackColor = Label4.BackColor
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
bonjour à tous(juste en passant)
si je compare le temps de (construction ou suppression) de 300 shapes ou label activx
alors j'imagine le poids du fichier a l'ouverture et fermeture
  1. il n'y a pas photo les shapes sont moins lourdes
  2. avec les shapes il suffit de leur affecter une macro (.onaction en vba)

dans cette exemple je crée 300 shapes en couleur carrée avec leur nom en tant que texte elles sont cliquables immédiatement âpres la construction
elle sont alignées en fonction de la constante Nbcolonne
VB: 
Option Explicit

Const largeur As Long = 50
Const hauteur As Long = 15
Const spaceX As Long = 10
Const NbColonne As Long = 20

Sub add300label()
    Dim L&, Tp&, i&, Feuille As Worksheet, lab As Shape
    delete300label
    Application.ScreenUpdating = False
    L = 20: Tp = 50    'L pour le left et tp pour le top
    Set Feuille = ActiveSheet
    With Feuille
        For i = 1 To 300
            Set lab = Feuille.Shapes.AddShape(1, L, Tp, largeur, hauteur)
            With lab
                .Fill.ForeColor.RGB = ThisWorkbook.Colors(Round(1 + (Rnd * 55)))
                .Name = "carre" & i
                .TextFrame.Characters.Text = .Name
                .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
                .TextFrame2.VerticalAnchor = msoAnchorMiddle
                .OnAction = "'label_click " & """carre" & i & """'"
            End With
            L = L + largeur + spaceX
            If i Mod NbColonne = 0 Then Tp = Tp + 20: L = 20
        Next
    End With
    Application.ScreenUpdating = False
End Sub
Sub delete300label()
    Dim obj
    For Each obj In ActiveSheet.Shapes
        If Left(obj.Name, 5) = "carre" Then obj.Delete
    Next
End Sub
Sub label_click(nom As String)
    MsgBox nom
End Sub
 
Vote positif 0 Vote négatif
Alors voilà,
tout d'abord, merci pour toutes vos propositions 🙂
je ne connais pas du tout les shapes (en fait, beaucoup de choses sont un peu du chinois pour moi 😅) donc je trouve plus simple de vous faire passer un fichier dans lequel j'ai pris le temps de faire un peu de ménage pour vous envoyer un truc à peu près propre 😇
si il y a un moyen de faire fonctionner mon module DupliMacroFeuil8, c'est top !
après, je sais qu'il doit y avoir des moyens plus pro et moins lourd pour faire les choses, mais je crée ce fichier à temps perdu pour mon plaisir perso, pas pour me former en programmation ☺️
 

Pièces jointes

Vote positif 0 Vote négatif
Merci !!!
Je vais tenter de voir si je peux réussir à comprendre tout ça et si je peux l'adapter 😉

Pour que vous compreniez ma situation : je suis entré dans le VBA en enregistrant des macros et en essayant de comprendre comment ça fonctionnait au fur et à mesure 😁 Alors là où vous faites 4x3, mois j'en suis à faire (1+1+1) + (1+1+1)+(1+1+1)+(1+1+1) et là ou vous faites des divisions ben je suis paumée 🤣
 
Dernière édition:
Vote positif 0 Vote négatif
C'est génial ! J'ai réussi à comprendre 😁
j'ai générer instantanément mes 640 cases (au lieu de copier manuellement mes labels 😆
j'ai réussi à définir ma couleur de fond de base
je vais insérer ma macro dans Label_click(nom as string)

il reste qu'un petit problème de mise en forme.
je voudrais pouvoir définir la couleur du texte & la couleur des bordures je n'ai rien trouvé dans les synthaxes de propriéteé des shapes

et du coup, je ne sais pas comment réécrire ma macro pour modifier la couleur du shape et inscrire la valeur dans la case correspondante 😅
 
Vote positif 0 Vote négatif
Alors au point ou j'en suis, même si c'est lourd et indigeste, j'aimerais tester la création de mes labels avec une automatisation comme proposée par patricktoulon en créant automatiquement mes labels à la place des shapes. et avec la fonction OnAction qui renvoi vers la macro qui fait référence au bon label.
En gro, remplacer dans sa proposition :
dim lab as Label
et set lab = feuille.Labels.AddLabel
mais écrit en langage compris par Excel 🤣 🤣
C'est possible ça ?
si je peux en plus donner la position de mes label en référence aux cases et définir leur couleur, couleur de texte et bordure, je suis la reine du monde 😛😁


 
Vote positif 0 Vote négatif
d'accords on est une bande de jeunes on se fent la gueule
c'est parti pour 640 rectangle de couleur différente aves le fontcolor différents et les bordures de couleur différente
et pour courroner le tout le pseudo event labelclick te done
  1. le nom
  2. le left
  3. le top
  4. la couleur de font
  5. la couleur du texte
  6. la couleur du contour
si t'en veux encore n'hésite pas j'en ai des kilos
VB: 
Option Explicit

Const largeur As Long = 50
Const hauteur As Long = 15
Const spaceX As Long = 10
Const NbColonne As Long = 20

Sub add300label()
    Dim L&, Tp&, i&, Feuille As Worksheet, lab As Shape, backcouleur&, fontcolor&, LineColor&
    Randomize
    delete300label
    Application.ScreenUpdating = False
    L = 20: Tp = 50    'L pour le left et tp pour le top
    Set Feuille = ActiveSheet
    With Feuille
        For i = 1 To 640
            backcouleur = ThisWorkbook.Colors(Round(1 + (Rnd * 55)))
            fontcolor = ThisWorkbook.Colors(Round(1 + (Rnd * 55)))
            LineColor = ThisWorkbook.Colors(Round(1 + (Rnd * 55)))
            Set lab = Feuille.Shapes.AddShape(1, L, Tp, largeur, hauteur)
            With lab
                .Fill.ForeColor.RGB = backcouleur
                .Name = "carre " & i
                .TextFrame.Characters.Text = .Name
                .TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
                .TextFrame2.VerticalAnchor = msoAnchorMiddle
                .Line.Visible = True
                .Line.ForeColor.RGB = LineColor
                .Line.Weight = 3
                .Parent.DrawingObjects(.Name).Font.Size = 8
                .Parent.DrawingObjects(.Name).Font.Color = fontcolor
                .OnAction = "'label_click " & """carre" & i & """'"
                'le .onaction argumenté
                .OnAction = "'label_click  " & Chr(34) & .Name & """,""" & _
                          L & """,""" & Tp & """,""" & backcouleur & """,""" & fontcolor & """,""" & LineColor & "'"

            End With
            L = L + largeur + spaceX
            If i Mod NbColonne = 0 Then Tp = Tp + hauteur + spaceX: L = 20
        Next
    End With
    Application.ScreenUpdating = False
End Sub
Sub delete300label()
    Dim obj
    For Each obj In ActiveSheet.Shapes
        If Left(obj.Name, 5) = "carre" Then obj.Delete
    Next
End Sub
Sub label_click(ByVal nom As String, ByVal Lleft As Long, ByVal Itop As Long, _
                ByVal backcouleur As Long, ByVal fontcolor As Long, ByVal LineColor As Long)
    
    Dim texte$
    texte = "Nom: " & nom & vbCrLf
    texte = texte & "left: " & Lleft & vbCrLf
    texte = texte & "top: " & Itop & vbCrLf
    texte = texte & "back color: " & backcouleur & vbCrLf
    texte = texte & "font color: " & fontcolor & vbCrLf
    texte = texte & "couleur du contour: " & LineColor


    MsgBox texte
End Sub

LOL!!!
 

Pièces jointes

Vote positif 0 Vote négatif
Bonjour Cmoiceli, patricktoulon, le forum,

La création de Labels ActiveX prend plus de temps mais ce n'est pas dramatique.

Voyez ce fichier (3), et le code dans Module1.

La création de 640 Labels prend chez moi 10 secondes (sans la RAZ).

Notez que l'initialisation de la classe doit se faire en différé par Application.OnTime.

A+
 

Pièces jointes

Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
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
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…