XL 2010 Dupliquer une sub

Cmoiceli · 10 Novembre 2022

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

job75 · 12 Novembre 2022

Bon d'accord Patrick sur ton ordi 640 ActiveX c'est dramatique.

patricktoulon · 12 Novembre 2022

re
ouais mon pauvre petit portable c'est de ta faute

j'imagine que 640 shapes avec mon model c'est même pas 2 secondes chez toi

job75 · 13 Novembre 2022

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+

patricktoulon · 13 Novembre 2022

Bonjour @job75

c'est moi c'est c'est donc plus rapide d'environ 41% c'est pas négligeable

TooFatBoy · 15 Novembre 2022

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 ?

mapomme · 15 Novembre 2022

Bonjour @TooFatBoy

TooFatBoy à dit:
1- pourquoi mettre 640 trucs, qui compliquent quand même pas mal le bouzin, sur une feuille ?

Parce que c'est un nombre rond bien sympathique et tout doux ( 5 * 2^7 ). Enfin presque

XL 2010 Dupliquer une sub

Cmoiceli

XLDnaute Nouveau

job75

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

patricktoulon

XLDnaute Barbatruc

TooFatBoy

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Discussions similaires