Insérer une forme automatique

[maval]

Bonjour

Suite au code de Staple1600 que j'ai trouver sur le site, est-il possible de copier et coller plusieurs Shapes en même temps?

https://www.excel-downloads.com/threads/copier-et-renommer-un-controle-en-vba.163813/
Merci d'avance

 

[maval]

Re : Insérer une forme automatique

Bonjour,

Personne a une idée

Bonne journée

 

[job75]

Re : Insérer une forme automatique

Bonsoir maval,

Depuis le temps que vous êtes sur ce forum, vous devriez savoir qu'il faut être précis et joindre un fichier.

Mai bon, ce code copie toutes les Shapes de Feuil1 et les colle sur Feuil2 :

Feuil1.DrawingObjects.Copy
With Feuil2 'CodeName
  .Paste
  .Activate
  ActiveCell.Activate
End With

A+

 

[job75]

Re : Insérer une forme automatique

Re,

Si l'on veut ne copier que certaines Shapes :

Feuil1.DrawingObjects(Array("tata", "titi", "toto")).Copy 'liste des noms
With Feuil2 'CodeName
  .Paste
  .Activate
  ActiveCell.Activate
End With

A+

 

[maval]

Re : Insérer une forme automatique

Bonjour Job75

Je vous remercie beaucoup des codes que vous m'avez transmis hier, si je n'abuse pas trop de votre temps.et si vous pourriez me dire comment faire mon code pour choisir l'onglet de copie et l'onglet de coller, je m'explique. J'ai fait un userForm avec deux combobox. La première, pour le choix de l'onglet à copier les Shapes et la deuxième pour la destination de l'onglet.

Je joint mon formulaire qui seras plus explicite.

Je vous remercie d'avance te vous souhaite une bonne journée

 

[job75]

Re : Insérer une forme automatique

Bonjour maval, le forum,

Avec un fichier on peut faire du travail sérieux :

Private Sub CommandButton1_Click()
If ComboBox1 = ComboBox2 Then Exit Sub
Dim F1 As Object, F2 As Object, a, e
Application.ScreenUpdating = False
On Error Resume Next 'si les Shapes n'existent pas
Set F1 = Sheets(ComboBox1.Text)
Set F2 = Sheets(ComboBox2.Text)
a = Evaluate("""Freeform ""&{27,35,25,23,19}") 'plus court que l'Array
For Each e In a
  F2.Shapes(e).Delete 'RAZ
Next
F1.Activate
For Each e In a
  F1.Shapes(e).Select False 'sélection multiple
Next
If TypeName(Selection) <> "Range" Then Selection.Copy: F2.Paste
F1.Activate: ActiveCell.Activate
F2.Activate: ActiveCell.Activate
Application.ScreenUpdating = True
End Sub

Edit : il faudrait sans doute définir la cellule sur laquelle se fait le collage (la cellule active).

Bonne journée.

 

[maval]

Re : Insérer une forme automatique

Bonjour Job

J'ai essayer le code sa me supprime bien les shapes mais sa ne les colle pas sur l'autre feuille ou en moins que j'ai fait une erreur.
La cellule ou se fait le collage est " E4".

 

[maval]

Re : Insérer une forme automatique

Re,

Au temps pour sa fonctionne très bien je l'ai essayé sur un autre PC sa fonctionne merci beaucoup je m'excuse, reste juste a programmer la cellule ou se fait le collage.

Les Shapes ont toutes le nom "SP-01 jusqu'à SP-100" Peut-on faire

For i = 1 To 100
a=Evaluate ("SP- " & Format ("00"))
Next i

pour éviter de marquer les noms a chaque fois?

Merci

 

[job75]

Re : Insérer une forme automatique

Message annulé, je n'avais pas vu votre dernier post.

 

[job75]

Re : Insérer une forme automatique

Re,

Dans ce cas plus besoin de définir le tableau a :

Private Sub CommandButton1_Click()
If ComboBox1 = ComboBox2 Then Exit Sub
Dim F1 As Object, F2 As Object, i As Byte
Application.ScreenUpdating = False
On Error Resume Next 'si les Shapes n'existent pas
Set F1 = Sheets(ComboBox1.Text)
Set F2 = Sheets(ComboBox2.Text)
For i = 1 To 100
  F2.Shapes("SP-" & Format(i, "00")).Delete 'RAZ
Next
F1.Activate
For i = 1 To 100
  F1.Shapes("SP-" & Format(i, "00")).Select False 'sélection multiple
Next
Application.Goto F2.[E4], True: F1.Activate
If TypeName(Selection) <> "Range" Then Selection.Copy: F2.Paste
ActiveCell.Activate
F2.Activate: ActiveCell.Activate
Application.ScreenUpdating = True
End Sub

Fichier joint.

Par ailleurs je vous prépare un autre fichier avec groupage des Shapes.

A+

 

[job75]

Re : Insérer une forme automatique

Re,

Les Shapes ne devant pas être séparées il vaut mieux en effet les grouper.

1) Exécutez d'abord cette macro dans Module1 :

Sub grouper()
Dim i As Byte
On Error Resume Next 'si des Shapes n'existent pas
Feuil4.Activate
For i = 1 To 100
  ActiveSheet.Shapes("SP-" & Format(i, "00")).Select False
Next
Selection.ShapeRange.Group.Name = "Groupe1" 'groupage
ActiveCell.Activate
End Sub

2) Le code dans l'USF est alors nettement plus simple :

Private Sub CommandButton1_Click()
If ComboBox1 = ComboBox2 Then Exit Sub
On Error Resume Next 'si la Shape n'existe pas
Sheets(ComboBox2.Text).Shapes("Groupe1").Delete 'RAZ
Sheets(ComboBox1.Text).Shapes("Groupe1").Copy
Application.Goto Sheets(ComboBox2.Text).[E4], True
Sheets(ComboBox2.Text).Paste
ActiveCell.Activate
End Sub

Fichier (2).

A+

 

[maval]

Re : Insérer une forme automatique

Re,

C'est vraiment Nickel je vous remercie beaucoup et vous souhaite un excellent WE

 

[job75]

Re : Insérer une forme automatique

Re,

Pour éviter toute surprise, mieux vaut vider préalablement le presse-papiers :

Private Sub CommandButton1_Click()
If ComboBox1 = ComboBox2 Then Exit Sub
[IV1].Copy [IV1] 'vide le presse-papiers
On Error Resume Next 'si la Shape n'existe pas
Sheets(ComboBox2.Text).Shapes("Groupe1").Delete 'RAZ
Sheets(ComboBox1.Text).Shapes("Groupe1").Copy
Application.Goto Sheets(ComboBox2.Text).[E4], True
Sheets(ComboBox2.Text).Paste
ActiveCell.Activate
End Sub

Fichier (3).

A+

 

[maval]

Re : Insérer une forme automatique

Re

Je vous remercie et je vous souhaite un excellent WE

 

[maval]

Re : Insérer une forme automatique

Bonjour,

Suite au code de Job75 qui fonctionne trés bien et que je salut et remercie au passage, j'aimerais lui apporter une petite modif si possible.

J'ai des zones texte qui représentent les noms des pays c'est zones texte sont grouper ensemble et porte le nom de "Groupe_Pays", j'aimerais copier les Shapes et le groupe_pays ensemble.

Je joint mon fichier qui seras plus explcite

Merci d'avance