Centrer/redimensionner une image dans une cellule

Le 21/12/2020 à 11:18

Bonjour à tous

J'espère que certains d'entre vous pourront m'aider. Avec une macro, j'aimerais pouvoir ajuster à la cellule ou centrer les images présentes dans un classeur en fonction de colonne ou ligne spécifiée.

Suite à mes recherches j'ai trouvé un code qui fonctionne bien, seulement il ajuste toutes les images de ma feuille. (https://forum.excel-pratique.com/excel/centrer-une-image-dans-une-cellule-85717)

Sur le fichier que je vous joins, j'aimerais pouvoir ajuster automatiquement à leur cellule toutes les images de la colonne "D" (la formule du dessus est géniale, mais il faudrait la faire s'appliquer qu'à la colonne D, j'ai essayé de modifier le Range de "Set c = obj.TopLeftCell", sans succès), centrer verticalement et horizontalement sans les redimensionner seulement les images de la colonne "K", et enfin, redimensionner à la cellule entière uniquement les images de la ligne 3 (ou des colonnes "N" à "AJ", c'est pareil).

Ca ne parait pas bien compliqué, et pourtant je bloque dessus depuis des jours.

Je vous remercie de votre aide

Antoine

41f1.zip (427.58 Ko)
Le 21/12/2020 à 12:34

Bonjour,

En vérifiant si l'objet (image) est bien une image en colonne D ...

Un essai ...

Sub voitures()
Dim obj As Shape, c As Range, p As Long

   For Each obj In ActiveSheet.Shapes
      'Debug.Print obj.Type, obj.Name
      If obj.Type = msoPicture Then
         Set c = obj.TopLeftCell

         ' ajuster hauteur
         If c.Column = 4 Then
'''            obj.Select  '' sélection de l'objet pour fin de tests
            obj.Height = c.Height - 2
            obj.Top = c.Top + 1
            ' centrer
            obj.Left = c.Left + (c.Width - obj.Width) / 2
         End If
      End If
   Next obj
End Sub

ric

Le 21/12/2020 à 15:00

Super, merci beaucoup. J'ai essayé sur la colonne des drapeaux et ça fonctionne parfaitement. En revanche, ça m'a redimensionné leur taille.

Est-ce que c'est possible de lui demander de simplement centrer horizontalement et verticalement, sans retoucher la taille ?

Edit: Réussi ! Je laisse la macro ici pour ceux qui auraient le meme besoin que moi.

Sub drapeaux()
Dim obj As Shape, c As Range, p As Long

   For Each obj In ActiveSheet.Shapes
      'Debug.Print obj.Type, obj.Name
      If obj.Type = msoPicture Then
         Set c = obj.TopLeftCell

         ' ajuster hauteur
         If c.Column = 11 Then
'''            obj.Select  '' sélection de l'objet pour fin de tests
            obj.Top = c.Top + (c.Height - obj.Height) / 2
            ' centrer
            obj.Left = c.Left + (c.Width - obj.Width) / 2
         End If
      End If
   Next obj
End Sub

En revanche, je sèche pour ajuster la taille à toute la cellule pour les drapeaux de la ligne 3 (ou des colonnes N à AJ). Quelqu'un aurait la formule miracle ? :D

Le 21/12/2020 à 16:43

Bonjour,

Colonne D > If c.Column = 4 Then

Colonne K >   If c.Column = 11 Then 

Range(N3:AJ3) >   If c.Row = 3 And c.Column > 13 And Column < 37 Then 

ric

Le 21/12/2020 à 17:10

Super merci ! Simple, concis et efficace

Est-ce c'est faisable d’étendre automatiquement une image à la taille d'une cellule ou c'est peine perdue ?

Le 21/12/2020 à 17:21

Bonjour,

Oui > mais cela va déformer l'image ...

            obj.LockAspectRatio = msoFalse
            obj.Top = c.Top + 1
            obj.Left = c.Left + 1
            obj.Width = c.Width -2
            obj.Height = c.Height -2

ric

Le 21/12/2020 à 17:52

Un grand merci à vous. La déformation n'est pas un problème dans mon cas.

Le code fonctionne tés bien à ce niveau.

capture d e cran 2020 12 21 a 17 47 24

En revanche, je m’aperçois d'un problème sur le centrage des images, les drapeaux ne s'ajustent pas correctement sur la cellule :

capture d e cran 2020 12 21 a 17 47 10

Pour arriver au résultat de la photo 1, j'ai du le faire manuellement. Une idée d'où ça peut venir ?

Sub Circuits()
Dim obj As Shape, c As Range, p As Long

   For Each obj In ActiveSheet.Shapes
      'Debug.Print obj.Type, obj.Name
      If obj.Type = msoPicture Then
         Set c = obj.TopLeftCell

         ' ajuster hauteur
        If c.Row = 2 And c.Column > 14 And Column < 39 Then
            obj.LockAspectRatio = msoFalse
            obj.Top = c.Top + 1
            obj.Left = c.Left + 1
            obj.Width = c.Width - 2
            obj.Height = c.Height - 2
         End If
      End If
   Next obj
End Sub
Le 21/12/2020 à 18:01

Bonjour,

Est-ce que tu as supprimé les autres propriétés ?

Essai ceci ...

Sub voitures()
Dim obj As Shape, c As Range, p As Long

   For Each obj In ActiveSheet.Shapes
      'Debug.Print obj.Type, obj.Name
      If obj.Type = msoPicture Then
         Set c = obj.TopLeftCell

         ' ajuster hauteur  Voitures
         If c.Column = 4 Then
            obj.LockAspectRatio = msoFalse
            obj.Top = c.Top + 1
            obj.Left = c.Left + 1
            obj.Width = c.Width - 2
            obj.Height = c.Height - 2
         End If

         ' ajuster hauteur  drapeaux ligne 3
         If c.Row = 3 And c.Column > 13 And Column < 37 Then
            obj.LockAspectRatio = msoFalse
            obj.Top = c.Top + 1
            obj.Left = c.Left + 1
            obj.Width = c.Width - 2
            obj.Height = c.Height - 2
         End If

         ' ajuster hauteur    drapeaux colonne k
         If c.Column = 11 Then
            obj.LockAspectRatio = msoFalse
            obj.Top = c.Top + 1
            obj.Left = c.Left + 1
            obj.Width = c.Width - 2
            obj.Height = c.Height - 2
         End If
      End If
   Next obj
End Sub

ric

Le 22/12/2020 à 12:26

Bonjour,

Grand merci à toi. Tout est rentré dans l'ordre ce matin, en ré-ouvrant le fichier. J'ai quand même modifié la macro par celle-ci (plus propre que plusieurs macros)

Le 22/12/2020 à 12:46

ric

Le 22/12/2020 à 12:48

Merci pour ton aide en tout cas. Pour toi c'est probablement tout bete, mais pour moi c'est effrayant

Question qui n'a rien à voir avant de marquer le sujet comme résolu, est-ce qu'il est possible d'établir un classement selon des points gagnés en course en fonction de la position ? Par exemple, celui qui termine 1er=25 point, 2ème=20 points, 20ème=0 points etc etc ?

Quelle formule privilégier ?

Le 22/12/2020 à 12:55

Bonjour,

Je suis vraiment désolé > je ne suis pas habile du tout avec les formules ...

ric

Le 22/12/2020 à 13:02

Bonjour si il s'agit de placer une image dans un range centrés et redimentionnée sans modifier son aspect ratio et quelque soit le ratio range/image

j'ai une fonction toute prete

'sub de placement et centrage de l'image  dans la range en parametre tout en respectant son  ratio
Sub place_l_image_dans(Rng As Range, Shp As Picture, Optional space = 0)
    Dim ratio#, W#, H#
    With Shp
        .ShapeRange.LockAspectRatio = msoTrue    ' lock leratio indéformable
        ratio = .Width / .Height     ' calcul ratio
        W = Rng.Width       ' width  range
        H = Rng.Height      ' height range
        If (W / H < ratio) Then
            .Width = W - space    'en redimentionant le width le height se redimentionne automatiquement
        Else    'ou
            .Height = H - (space / ratio)    'en redimentionant le height le width se redimentionne automatiquement
        End If
        .Left = Rng.Left + ((Rng.Width - .Width) / 2)
        .Top = Rng.Top + ((Rng.Height - .Height) / 2)
        .Placement = 1
    End With
End Sub

exemple

Sub testx()
place_l_image_dans [B3:C10], ActiveSheet.Pictures("image1")
End Sub

l'image sera centré dans la plage et redimensionnée si besoins mais gardera son aspect ratio

faire une recherche dans les ressources de exceldownloads avec mon pseudo

il y a aussi la méthode indirect et une autre abrégée

Rechercher des sujets similaires à "centrer redimensionner image"