Discussion :

[bobafric]

bonjour à tous,

j'ai un classeur avec les feuilles image et classement.
Dans la feuille image je voudrai en cliquant sur les images les coller dans la feuille classement dans des cellules choisies B3 puis D3 puis C2 puis C4.
Le choix des images est aléatoire, mais la première image cliquée doit se retrouver en B, la deuxième en D etc....
dans le fichier ci-joint les clics rangent les images dans un ordre régulier: A1, puis B1, puis C1 etc...
merci d'avance
Bob

[BlueMonkey]

Salut,

En déplaçant l'image après insertion, au sein de la routine Sub Classement().

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
 
Sub Classement()
    '...
    ActiveSheet.Paste 'coller de l'image
 
    With Sheets("classement")
        AjustShapeToRange .Shapes(.Shapes.Count), _
                          .Range(GetTargetRange(Compteur))
    End With
 
    '...
End Sub

Les fonctions utilisées :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub AjustShapeToRange(sh As Shape, r As Range)
    sh.LockAspectRatio = msoFalse
    sh.Width = r.Width - 6
    sh.Height = r.Height - 6
    sh.Top = r.Top + 3
    sh.Left = r.Left + 3
End Sub
 
Function GetTargetRange(ByVal index As Byte) As String
    Select Case (index)
        Case 1: GetTargetRange = "B3"
        Case 2: GetTargetRange = "D3"
        Case 3: GetTargetRange = "C2"
        Case 4: GetTargetRange = "C4"
 
        Case Else: GetTargetRange = "A1"
    End Select
End Function

A+

[bobafric]

Salut Blue Monkey
Merci pour ta réponse mais je ne sais pas où et comment introduire ton code.
Est-ce que je dois supprimer le code existant sur le fichier.
dois-je l'introduire dans un module, une feuille, ou le worksheet.
Excuses-moi pour ma réponse tardive mais je suis en déplacement chez des amis pour ce week end.
Merci d'avance pour ton aide.
Bob

[BlueMonkey]

Salut,

Il faut simplement mettre à jour la routine existante Sub Classement() qui se trouve dans ton fichier sous Module1,
avec les modifications données précédemment.

Pour te simplifier l'opération, remplace tout ce qui se trouve dans Module 1 par ce qui suit.
Le reste fonctionne comme avant.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Public Compteur As Byte
Public Ligne As Byte
Sub Classement()
    Compteur = Compteur + 1
    If Ligne = 0 Then
        Ligne = 1
    End If
'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").Activate
    Cells(Ligne, Compteur).Select
    ActiveSheet.Paste
    With Sheets("classement")
            AjustShapeToRange .Shapes(.Shapes.Count), _
                              .Range(GetTargetRange(Compteur))
    End With
 
 
    Sheets("image").Activate
 
    If Compteur * Ligne = 30 Then
        MsgBox "Classement terminé."
        Sheets("classement").Activate
    End If
 
    If Compteur = 15 Then
        Compteur = 0
        Ligne = Ligne + 1
    End If
 
End Sub
 
Sub AjustShapeToRange(sh As Shape, r As Range)
    sh.LockAspectRatio = msoFalse
    sh.Width = r.Width - 6
    sh.Height = r.Height - 6
    sh.Top = r.Top + 3
    sh.Left = r.Left + 3
End Sub
 
Function GetTargetRange(ByVal index As Byte) As String
    Select Case (index)
        Case 1: GetTargetRange = "B3"
        Case 2: GetTargetRange = "D3"
        Case 3: GetTargetRange = "C2"
        Case 4: GetTargetRange = "C4"
 
        Case Else: GetTargetRange = "A1"
    End Select
End Function

[bobafric]

Merci BlueMonkey
C'est impeccable.
A la prochaine
Bob