VBA Copie d'image en fonction de la valeur de la cellule

[MokoyFab]

Bonjour à tous,

une nouvelle fois, je bloque sur un bout de code.
En effet, je souhaite copier les images d'une feuille à une autre en fonction des valeurs de cellules.
Pour la zone F9:F104, je voudrais lire les valeurs de chaque cellule et aller voir dans la feuille "Equipes" si il y a une image qui porte le même nom que la valeur récupérée. Si oui, je souhaiterais copier l'image dans les cellules correspondantes de la colonne G.
Par exemple, la valeur de ma cellule F9 étant "Autriche", je voudrais aller voir dans la feuille "Equipes" si il y a une image nommée "Autriche", et si oui, la copier en G9, de préférence centrée.
J'arrive à récupérer les valeurs de la colonne F, les numéros de ligne, mais je bloque ensuite sur la copie des images.
Je vous joint le fichier pour plus de "visibilité". 🙂

Merci une fois de plus.

 

[mromain]

Re : VBA Copie d'image en fonction de la valeur de la cellule

Bonjour MokoyFab, bonjour le forum,

Voici un exemple :

Sub test()
Dim sheetShapes As Worksheet, iRow As Long, laShape As Shape, sheetPoules As Worksheet
Set sheetShapes = ThisWorkbook.Sheets("Equipes")
Set sheetPoules = ThisWorkbook.Sheets("Phase de poules")

On Error Resume Next
For iRow = 9 To 104
Set laShape = Nothing
Set laShape = sheetShapes.Shapes(sheetPoules.Range("F" & iRow).Text)
If Not laShape Is Nothing Then
laShape.Copy
sheetPoules.Paste
With sheetPoules.Shapes(sheetPoules.Shapes.Count)
.Left = sheetPoules.Range("H" & iRow).Left + ((sheetPoules.Range("H" & iRow).Width - .Width) / 2)
.Top = sheetPoules.Range("H" & iRow).Top + ((sheetPoules.Range("H" & iRow).Height - .Height) / 2)
End With
End If
Next iRow
On Error Resume Next
End Sub

A+

 

[MokoyFab]

Re : VBA Copie d'image en fonction de la valeur de la cellule

Merci pour votre réponse Romain.
Je vais tester.
En faisant des tests, j'étais arrivé à bout de code qui fonctionne, mais qui me semble trop lours et qui doit pouvoir largement être amélioré.

Sub CopyLogos()
Dim NomEquipe As String, NumLigne As Integer, S As Shape
For Each Cell In Sheets("Phase de poules").Range("F9:F104")
    NomEquipe = Cell.Value
    NumLigne = Cell.Row
    For Each S In Sheets("Equipes").Shapes
        If S.Name = NomEquipe Then
            S.Copy
            Range("G" & NumLigne).Select
            ActiveSheet.Paste
        End If
    Next
Next
End Sub

 

[PMO2]

Re : VBA Copie d'image en fonction de la valeur de la cellule

Bonjour,

Voir la pièce jointe

 

[MokoyFab]

Re : VBA Copie d'image en fonction de la valeur de la cellule

Bonjour PMO2, merci pour votre réponse.
De ce que j'ai vu et testé, chacune des deux macros a ses avantages.
Celle de Romain permets de garder exactement la proportion des images, mais celle de PMO2 me semble plus rapide.
Je vais essayer de scinder les deux pour arriver à un résultat parfait, enfin pour moi 😀
Merci encore à vous deux.