Delete shape in specific merged cell

[YasserKhalil]

Hello everyone
I have a merged cell E2:I15 where I inserted images in the worksheet change event. When the code is executed, the image is inserted many times so I have to delete the image before the new call.
I tried the following lines that work partially (some images deleted while some other images don't respond to the delete)

Code: Select all

    For Each shp In ActiveSheet.Shapes
        If Not Intersect(shp.TopLeftCell, Range(sImageAddress)) Is Nothing Then shp.Delete
    Next shp

Any ideas?

[HansV]

Does this work better?

Code: Select all

    Dim i As Long
    For i = ActiveSheet.Shapes.Count To 1 Step -1
        Set shp = ActiveSheet.Shapes(i)
        If Not Intersect(shp.TopLeftCell, Range(sImageAddress)) Is Nothing Then shp.Delete
    Next i

[YasserKhalil]

Thanks a lot, my tutor. The same problem
The weird point is that it works with some images and some other images don't respond.
Some of the images don't respond with the .png extension, can this be a problem with the image itself?

[HansV]

I don't see how that would affect the code.
Are you sure that the upper left corner of the shapes is in the specified cell, and not in the cell above or to the left?

[YasserKhalil]

Yes, I am sure as I used these lines when inserting the image

Code: Select all

        If Dir(sImagePath) <> "" Then
            Set pic = shMain.Pictures.Insert(sImagePath)
            With pic
                .ShapeRange.LockAspectRatio = msoFalse
                .Left = cel.Left
                .Top = cel.Top
                .Width = cel.Width
                .Height = cel.Height
                .Placement = xlMove
                .Name = "Picture_" & sImageName
            End With
        End If

[YasserKhalil]

After posting the code in my previous post, I had an idea and it worked for me

Code: Select all

            For Each shp In ActiveSheet.Shapes
                If Left(shp.Name, 7) = "Picture" Then shp.Delete
            Next shp

[DocAElstein]

Hello,

After posting the code in my previous post, I had an idea and it worked for me
......... For Each ...
....
......... Next ...

One small point: If you are Deleteing things its usually better to loop backwards like what Hans did

If you loop other ways then the delete usually causes things "ahead of you" which are not yet considered to get re ordered and this can mess up the ordered progression through all things.
If you loop backwards then effectively when you Delete stuff you do it to things “behind you” which you have already considered, so the things not yet considered are still in the correct order, and so usually all is well.

Try the 3 demo macros below to see what I mean, - they all start with this
Pick 1
Pick 2
Pick 3
Pick 4
Pick 5
, then they all try to delete the cell if its got either Pick 2 or Pick 3 in it.

One loops forwards, one uses the For Each Next way and the last loops backwards.
Only the one looping backwards takes out both Picks


Alan

3 Demo macros:

Code: Select all

 Option Explicit

Sub TakeYourPickorTwoIfYouIsLucky()
 Call TakeAPick        ' Forward  loop
 Call TakesAPickForFun ' For Each Next  loop
 Call TakeAPick2and3   ' Backward  loop
End Sub

Sub TakeAPick() '  https://eileenslounge.com/viewtopic.php?p=304348#p304348
 Let Range("A1:A5").Value2 = Evaluate("=" & """" & "Pick " & """" & "&" & "ROW(A1:A5)")

Debug.Print "Loop forward"
Dim Cnt As Long
    For Cnt = 1 To 5 Step 1
    Dim Messij As String
     Let Messij = "Considering Cell " & Range("A" & Cnt & "").Address & " , value """ & Range("A" & Cnt & "").Value2 & """"
        If Range("A" & Cnt & "").Value2 = "Pick 2" Or Range("A" & Cnt & "").Value2 = "Pick 3" Then
         Let Messij = Messij & " , then taking out Pick " & Right(Range("A" & Cnt & "").Value2, 1)
         Range("A" & Cnt & "").Delete Shift:=xlUp ' Note that in an example similar to this one,  Shift:=xlUp  , would probably be the default used it you did not specify a  Shift  direction
        Else
        End If
    Debug.Print Messij
    Next Cnt

Debug.Print
End Sub


Sub TakesAPickForFun()
 Let Range("A1:A5").Value2 = Evaluate("=" & """" & "Pick " & """" & "&" & "ROW(A1:A5)")

Debug.Print "Loop  For Next  Fun"
Dim Sel As Range
    For Each Sel In Range("A1:A5")
    Dim Messij As String
     Let Messij = "Considering Cell " & Sel.Address & " , value """ & Sel.Value2 & """"
        If Sel.Value2 = "Pick 2" Or Sel.Value2 = "Pick 3" Then
         Let Messij = Messij & " , then taking out Pick " & Right(Sel.Value2, 1)
         Sel.Delete Shift:=xlUp ' Note that in an example similar to this one,  Shift:=xlUp  , would probably be the default used it you did not specify a  Shift  direction
        Else
        End If
    Debug.Print Messij
    Next Sel

Debug.Print

End Sub

Sub TakeAPick2and3()
 Let Range("A1:A5").Value2 = Evaluate("=" & """" & "Pick " & """" & "&" & "ROW(A1:A5)")

Debug.Print "Loop backwards"
Dim Cnt As Long
    For Cnt = Range("A1:A5").Cells.Count To 1 Step -1
    Dim Messij As String
     Let Messij = "Considering Cell " & Range("A" & Cnt & "").Address & " , value """ & Range("A" & Cnt & "").Value2 & """"
        If Range("A" & Cnt & "").Value2 = "Pick 2" Or Range("A" & Cnt & "").Value2 = "Pick 3" Then
         Let Messij = Messij & " , then taking out Pick " & Right(Range("A" & Cnt & "").Value2, 1)
         Range("A" & Cnt & "").Delete Shift:=xlUp ' Note that in an example similar to this one,  Shift:=xlUp  , would probably be the default used it you did not specify a  Shift  direction
        Else
        End If
    Debug.Print Messij
    Next Cnt

Debug.Print
End Sub

Results in Immediate window:

Code: Select all

 Loop forward
Considering Cell $A$1 , value "Pick 1"
Considering Cell $A$2 , value "Pick 2" , then taking out Pick 2
Considering Cell $A$3 , value "Pick 4"
Considering Cell $A$4 , value "Pick 5"
Considering Cell $A$5 , value ""

Loop  For Next  Fun
Considering Cell $A$1 , value "Pick 1"
Considering Cell $A$2 , value "Pick 2" , then taking out Pick 2
Considering Cell $A$3 , value "Pick 4"
Considering Cell $A$4 , value "Pick 5"

Loop backwards
Considering Cell $A$5 , value "Pick 5"
Considering Cell $A$4 , value "Pick 4"
Considering Cell $A$3 , value "Pick 3" , then taking out Pick 3
Considering Cell $A$2 , value "Pick 2" , then taking out Pick 2
Considering Cell $A$1 , value "Pick 1"

(PS. I think I recal seeing some Tutorial Blog post here at Eileen's lounge on this looping baclkwards issue? At first look I couldn't find it)