ranger des images sur une feuille à partir d'un classeur

[bobafric]

Bonjour à tous.
J’ai un classeur « Album »
Dans ce classeur : une feuille « Image »
Une feuille « classement »

Dans la feuille Image 30 images que j’ai insérées à partir d’un album quelconque.
Je voudrais en cliquant ( doubleClic ou ClicDroit) sur ces images , les coller sur la feuille classement, de la gauche vers la droite les unes après les autres dans l’ordre choisit en cliquant,
Je m’explique.
Le Clic sur [image 3] la colle en haut à gauche de ma feuille.
Le Clic sur la suivante [image 18] par exemple la colle en haut juste à droite de l’image 3, etc, etc. Soit image 3 dans cellule A1, image 18 dans cellule A2 etc,etc.
Les cellules qui reçoivent les images dans la feuille classement sont un peu plus grandes que les images.
Je veux alligner 15 images sur la première ligne soit de A1 à A15
et les 15 autres sur la suivante soit de B1 à B15.
Dès qu’une image est classée on ne doit plus pouvoir la sélectionner.
A la fin de l’opération je dois réinitialiser les feuilles en cliquant sur un bouton.
J’avais déjà obtenu une solution il y a quelques temps mais je l’ai perdue dans un formatage inconsidéré.
Je vous en livre une partie ci-dessous mais elle est incomplète et ne fonctionne pas.

Code dans la feuille [images]
Bouton (CommandButton1) sur la feuille image associé à la macro Initialisation

Option Explicit
Dim Compteur As Byte
Dim Sh As Shape
Dim Ligne As Byte
Private Sub CommandButton1_Click()
   With UsedRange 'Attention efface tour le texte et les couleurs de fond, adapte au besoin
      .Interior.ColorIndex = xlNone
      .ClearContents
   End With
   
   'affectation des macros aux images
   For Each Sh In Sheets("image").Shapes
      If Not Sh.Name Like "CommandButton1" Then Sh.OnAction = "Feuil1.Classement"
   Next Sh
   
   'suppression des images de la feuille classement
   For Each Sh In Sheets("classement").Shapes
      Sh.Delete
   Next Sh
 
   Compteur = 0
   Ligne = 1
 
End Sub
Sub Classement()
Compteur = Compteur + 1
 
'suppression de la macro pour ne pas recliquer sur la même image
'et par la même occasion ne pas avoir d'image cliquable sur la feuille de destination
Sheets("image").Shapes(Application.Caller).OnAction = ""
 
'copie de l'image
Sheets("image").Shapes(Application.Caller).Copy
 
'fond de cellule rouge et position
With Range(Sheets("image").Shapes(Application.Caller).TopLeftCell.Address)
   .Interior.ColorIndex = 3
   .Value = Compteur + (Ligne - 1) * 15
End With
 
'collage de l'image
Sheets("classement").Cells(Ligne, Compteur).PasteSpecial "Image (GIF)"
 
If Compteur * Ligne = 30 Then MsgBox "Classement terminé.": _
   Application.Goto Sheets("classement").Range("A1"): Exit Sub
 
If Compteur = 15 Then Compteur = 0: Ligne = Ligne + 1
End Sub

Voila je crois que mon message est complet, merci pour votre aide.
Cordialement Bob

 

[danaxia]

Re : ranger des images sur une feuille à partir d'un classeur

Bonsoir bobafric si tu pouvais joindre le fichier pour pouvoir l'étudier, Courage.

 

[bobafric]

Re : ranger des images sur une feuille à partir d'un classeur

Bonjour danaxia
Je ne peux pas joindre le fichier car il est trop lourd pour ce forum.
Je te fais un topo
Feuille IMAGE
PHOTO1 PHOTO 2 ................PHOTO 15
PHOTO16.............................PHOTO30
les photo format 3 X 2
bouton commande1

Feuille CLASSEMENT
30 cellules sur 2 rangées d'un format 3,2 X 2,2

Le code appliqué à la feuille IMAGE

C'est tout ce que je peux te dire pour l'instant
Merci BOB