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
  • Initiateur de la discussion Initiateur de la discussion Cmoiceli
  • Date de début Date de début

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

Guest
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, patricktoulon, le forum,

Chez moi la création de 640 Shapes (Rectangles) se fait en 0,6 seconde :
VB: 
Sub USF()
UserForm1.Caption = "Couleur " & Application.Caller
UserForm1.Show
End Sub

Sub Dupliquer()
'se lance par Ctrl+D
Dim t, F As Worksheet, obj As Shape, objX, objY, w, h, decal, s As Shape, i&, j&, n&
t = Timer
Set F = Feuil1
Set obj = F.Shapes("Rectangle 1")
objX = obj.Left: objY = obj.Top
w = obj.Width: h = obj.Height
decal = 10
Application.ScreenUpdating = False
'---RAZ---
For Each s In F.Shapes
    If s.Name Like "Rectangle #*" And s.Name <> "Rectangle 1" Then s.Delete
Next
'---duplication---
For i = 1 To 20
    For j = 1 To 32
        n = n + 1
        If n > 1 Then
            Set s = obj.Duplicate
            s.Name = "Rectangle " & n
            s.TextFrame.Characters.Text = "Rectangle " & n
            s.Left = objX + (j - 1) * (w + decal)
            s.Top = objY + (i - 1) * (h + decal)
        End If
Next j, i
Application.ScreenUpdating = True
MsgBox "Durée " & Format(Timer - t, "0.00 \sec")
End Sub
A+
 

Pièces jointes

Vote positif 0 Vote négatif
Moi, je me pose deux questions :
1- pourquoi mettre 640 trucs, qui compliquent quand même pas mal le bouzin, sur une feuille ?
2- pourquoi aucune nouvelle du demandeur malgré de nouvelles réponses dans son fil ?
 
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
Assurez vous de marquer un message comme solution pour une meilleure transparence.
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…