Microsoft 365 supression image

L

luc50*

XLDnaute Nouveau
bonjour
débutant en vba je cherche a sélectionner un plage donne et a supprimer les images quelle contient mais sa bloque dan ma formule

For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell,Range("$B$149:$Q191")) Is Nothing Then s.delete
Next s
 
Solution
Staple1600
Re

Et en bonus, un macro pour supprimer les six images d'un coup
(test OK sur mon PC)
VB: 
Sub Delete_All_Imgs()
Dim supprIMG, i As Byte
On Error Resume Next
supprIMG = Array("C149:H160", "K149:O160", "C162:H174", "K162:O174", "C176:H188", "K176:O188")
For i = LBound(supprIMG) To UBound(supprIMG)
ActiveSheet.Shapes("img" & supprIMG(i)).Delete
Next
End Sub
Trier par date Trier par votes
Staple1600

Staple1600

XLDnaute Barbatruc
Bonjour

test ok chez moi
VB: 
Sub Test()
Dim s As Shape
For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell, Range("$B$149:$Q191")) Is Nothing Then
MsgBox s.TopLeftCell.Offset.Address 'pour test
s.Delete
End If
Next s
End Sub
NB: Le MsgBox s'est juste pour être sur qu'il y a bien des images en colonne B.
A supprimer ensuite.
 
Vote positif 0 Vote négatif
L

luc50*

XLDnaute Nouveau
Bonjour
la photo est mise automatiquement a cet emplacement grâce a la macro suivante:
Sub image1()

Range("C149:H160").Select

Dim ficimg As String, Ad As String
Ad = Selection.Address
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set Image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, ActiveCell.Left, ActiveCell.Top, Range(Ad).Width, Range(Ad).Height)
With Image
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez
.Placement = xlMoveAndSize
End With
End Sub

et après dans ma macro d’effacement je reprend les même cellules ("C149:H160")
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
RE

Fais ce test, sur une feuille vide
1) Lance la macro Créer_TEST
2) Lance ensuite la macro: Test_II
VB: 
Sub Créer_TEST()
Dim i%, shp As Shape
ActiveSheet.DrawingObjects.Delete
For i = 1 To 10
Set shp = ActiveSheet.Shapes.AddShape(78 + i, 2 + (i * 75), 80, 53.25, 46.5)
shp.BackgroundStyle = 1 + i
shp.Fill.ForeColor.RGB = RGB(255, 255 - (i * 11), 0)
Next
End Sub
Sub Test_II()
Dim s As Shape
For Each s In ActiveSheet.Shapes
If Not Intersect(s.TopLeftCell, Range("B:G")) Is Nothing Then
s.Delete
End If
Next s
End Sub
Seules les "images" en colonnes B:G seront effacées.
(En tout cas, c'est le cas sur mon PC.)
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
bonjour
  1. les select ou autre activate on peut s'en passer
  2. quand on insert une shape/picture on la nomme
  3. et si cette shape doit être en corrélation avec une plageon la nomme en corrélation avec la plage
conclusion
VB: 
Sub image1()
    Dim ficimg As String, image As Shape, Rng As Range
   Set Rng = Range("C149:H160")
     ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image")    ' choix du fichier
    If ficimg = Faux Then Exit Sub
    Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
    With image
        .Name = "img" & Rng.Address(0, 0)
        .LockAspectRatio = False    'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
        .Placement = xlMoveAndSize
    End With
End Sub
'
'
'
Sub supprime_image()
    Dim Rng As Range, shp As Shape
    Set Rng = Range("C149:H160")
    Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
    If Not shp Is Nothing Then shp.Delete
End Sub
bonne route ;)
 
Vote positif 0 Vote négatif
L

luc50*

XLDnaute Nouveau
Bonjour0 vous deux et encore merci pour vos idées
la solution de paticktoulon fonctionne parfaitement j'arrive a mettre mes six phots au emplacements prévu par contre effacement rencontre un bug des que l'emplacement de mes photos et vide
MACRO POUR METTRE AFFICHE JUSQU’À SIX PHOTOS

(chaque macro est relie a un bouton différent)


Sub NEWIMAG1()
Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("C149:H160")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub

Sub NEWIMG2()
Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("K149:O160")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub

Sub NEWIMG3()
Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("C162:H174")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub

Sub NEWIMG4()
Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("K162:O174")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub
Sub NEWIMG5()

Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("C176:H188")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub
Sub NEWIMG6()

Dim ficimg As String, image As Shape, Rng As Range
Set Rng = Range("K176:O188")
ficimg = Application.GetOpenFilename(".jpg,*.jpg", , "Choisissez l'image") ' choix du fichier
If ficimg = Faux Then Exit Sub
Set image = ActiveSheet.Shapes.AddPicture(ficimg, False, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height)
With image
.Name = "img" & Rng.Address(0, 0)
.LockAspectRatio = False 'proportions d'origine lorsque vous la redimensionnez(faux!!!!!!!)
.Placement = xlMoveAndSize
End With
End Sub


MACRO QUI DOIT ME PERMETTRE D'EFFACER TOUTES LES PHOTOS
Cela me met une erreur dès qu'un emplacement defini plus haut est vide
je n'arrive pas a passe a l'emplacement suivant si l'emplacement est vide
Sub SUPIMG()
Dim Rng As Range, shp As Shape
Set Rng = Range("C149:H160")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

Set Rng = Range("K149:O160")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

Set Rng = Range("C162:H174")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

Set Rng = Range("K162:O174")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

Set Rng = Range("C176:H188")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

Set Rng = Range("K176:O188")
Set shp = ActiveSheet.Shapes("img" & Rng.Address(0, 0))
If Not shp Is Nothing Then shp.Delete

End Sub
 
Vote positif 0 Vote négatif
L

luc50*

XLDnaute Nouveau
Desole
staplle 1600 j ai fait ton test et il n'efface effectivement que les images en colonne b et g
et moi j'ai des photo en c k h o en plus de b et g et je ne suis pas parvenu a tous concilie
mais si tu a une solution pour tout effacer je suis preneur
 
Vote positif 0 Vote négatif

Discussions similaires

W
  • Question
XL 2016 Supprimer une image.JPG puis Intégrer une nouvelle.JPG au-dessus du groupe de cellules A13:A14
Réponses
4
Affichages
293
Webperegrino
W
D
  • Question
XL 2021 VBA - Erreur 1004 aléatoire - Image/Logo
Réponses
10
Affichages
371
crocrocro
C
M
  • Question
XL 2013 changement de couleur de police qd cellule modifiée
Réponses
10
Affichages
296
michel.dupont
M
T
  • Question
Microsoft 365 Images ne s'affiche pas dans fichier Excel
Réponses
5
Affichages
510
job75
job75
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
474
Phil69970
Phil69970
A
  • Question
XL 2016 Adapter une image à une cellule
2
Réponses
16
Affichages
1 K
Dudu2
Dudu2
José Alain
  • Résolu(e)
Word Insérer plusieurs images en même temps.
Réponses
3
Affichages
250
Alanou
A
pascal21
  • Question
XL 2019 compter des commentaires
Réponses
2
Affichages
296
pascal21
pascal21
L
  • Question
Microsoft 365 vba Outlook traiter un fichier excel lors de sa reception
Réponses
0
Affichages
282
lesoldat9
L
U
  • Question
Autres [RÉSOLU] Faire afficher ligne sur tout le classeur par double clic et la faire maquer à l’enregistrement
Réponses
11
Affichages
416
un internaute
U

Membres actuellement en ligne

13 membres et 186 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 310
Messages
2 087 119
Membres
103 478
dernier inscrit
Frederic Lagger