XL 2010 Dupliquer une sub

[Cmoiceli]

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]

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

 

[patricktoulon]

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]

Bonjour Cmoiceli, patricktoulon, le forum,

Chez moi la création de 640 Shapes (Rectangles) se fait en 0,6 seconde :

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]

Bonjour @job75

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

 

[TooFatBoy]

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]

Bonjour @TooFatBoy

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