Redimensionner une selection d'image

Version imprimable

30/10/2024, 02h42
Willo83

Redimensionner une selection d'image

Bonjour,
mon classeur Excel contient environ 300 feuilles.
Sur chaque feuille, il y a 2 images.
J'aimerais sélectionner juste une seule image par feuille et les redimensionner à taille égale.
J'ai trouvé un bout de code sur le forum qui me permet de sélectionner la bonne image grâce à son emplacement sur la feuille, mais seulement sur la feuille active.

Sub Dimension()
For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell, Range("$A$1:$T25")) Is Nothing Then
s.Select False
End If
Next s
End Sub

Comment adapter ce code de façon a élargir la sélection sur toutes les feuilles et y insérer les dimensions que je veux?

Merci pour votre aide.
30/10/2024, 08h46
jurassic pork

Hello,
il est bizarre ton code :
1 - tu fais un shape select avec replace à false ce qui veut dire que tu étends la sélection avec l'objet précédemment sélectionné.
2 - On ne voit pas de code de redimensionnement.

si il y a deux images par feuille : où se situent ces deux images (plages) ? toujours au même endroit ?

Ami calmant, J.P
30/10/2024, 09h29
Willo83

Bonjour,
sur chaque feuilles, les images se trouvent toujours au même endroit.
30/10/2024, 09h44
jurassic pork

Pour pouvoir t'aider il faudrait voir à quoi ressemble ton classeur avec seulement 2 ou trois feuilles. Si il y a des données confidentielles les enlever. Pour les images si elles sont confidentielles :
cliquer droit sur l'image puis faire changer d'image / A partir d'icones et choisir n'importe quelle icone.
30/10/2024, 09h58
Willo83

1 pièce(s) jointe(s)

Voici un exemple de classeur.
J'aimerai redimensionner à la même taille, sur toutes feuilles , seulement l'image se situant en haut de la feuille.
Merci pour ton aide

Bonjour Willo83, jurassic pork, le forum,

Une proposition ci-dessous :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Public Sub RedimFirstShapes()
Dim shp As Shape
Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        Set shp = GetTopShape(ws)
        If Not shp Is Nothing Then
            shp.Width = 15
            shp.Height = 15
        End If
    Next ws
End Sub
 
Private Function GetTopShape(ws As Worksheet) As Shape
Dim topRow As Long
Dim shp As Shape
    topRow = ws.Rows.Count
    For Each shp In ws.Shapes
        If shp.TopLeftCell.Row < topRow Then
            topRow = shp.TopLeftCell.Row
            Set GetTopShape = shp
        End If
    Next shp
End Function

A+

30/10/2024, 10h30
Willo83

Bonjour mromain!
Ton code fonctionne très bien. Merci beaucoup.
Pourrais tu y ajouter cet élément:
-je souhaite que les images soient positionnées toute au même endroit , coin haut gauche dans l'angle gauche de la cellule H2

Si je veux sélectionner uniquement l'image du bas, quelle modification dois je apporter au code?

Merci.

Re-bonjour,

Voici le code modifié et à adapter :

Code:

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
Public Sub RedimShapes()
Dim shp As Shape
Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        'shape du haut
        Set shp = GetFirstShape(ws)
        If Not shp Is Nothing Then
            shp.Width = 75
            shp.Height = 75
            shp.Top = ws.Range("H2").Top
            shp.Left = ws.Range("H2").Left
        End If
        'shape du bas
        Set shp = GetFirstShape(ws, True)
        If Not shp Is Nothing Then
            shp.Width = 75
            shp.Height = 75
            shp.Top = ws.Range("I20").Top
            shp.Left = ws.Range("I20").Left
        End If
    Next ws
End Sub
 
Private Function GetFirstShape(ws As Worksheet, Optional fromBottom As Boolean = False) As Shape
Dim topRow As Long
Dim shp As Shape
    topRow = IIf(fromBottom, 0, ws.Rows.Count)
    For Each shp In ws.Shapes
        If ((Not fromBottom) And (shp.TopLeftCell.Row < topRow)) Or (fromBottom And (shp.TopLeftCell.Row > topRow)) Then
            topRow = shp.TopLeftCell.Row
            Set GetFirstShape = shp
        End If
    Next shp
End Function

A+

30/10/2024, 12h11
Willo83

Admirable! Un grand bravo!
Certaines photos ne se sont pas redimensionnées correctement car la case "conserver les proportions" était cochée.
Pourrait on demander à la macro de décocher avant d'ajuster la taille?
Merci.
30/10/2024, 14h38
mromain

Re,

Tu peux le faire en rajoutant cette ligne : shp.LockAspectRatio = False.

A+
30/10/2024, 15h07
Willo83

Tout est ok de mon côté.
Merci beaucoup de m'avoir aidé. J'ai gagné un temps fou!