Excel insert and remove pictures problem

[BrendanDixon]

Hi All,

I have a document where a buyer wants to insert his signature automatically. The code for installing the signature works fine. The problem is that when I run the code to remove the signature it removes all the signaures except for the signature in Cell A84. All the cells are identical so I cannot work out what is going on. I hope somone can help me work this out. I have spent 2 days on this problem without a solution so far.

Sub Insert()
Dim photoNameAndPath As Variant
Dim photo As Picture

photoNameAndPath = Application.GetOpenFilename(Title:="Select Photo to Insert")
If photoNameAndPath = False Then Exit Sub
    Set photo = ActiveSheet.Pictures.Insert(photoNameAndPath)
    With photo
       .Left = ActiveSheet.Range("A1").Left
       .Top = ActiveSheet.Range("A1").Top
       .Width = ActiveSheet.Range("A1:C3").Width
       .Height = ActiveSheet.Range("A1:C3").Height
       .Placement = 1

    End With
    
    Set photo = ActiveSheet.Pictures.Insert(photoNameAndPath)
    With photo
       .Left = ActiveSheet.Range("B10").Left
       .Top = ActiveSheet.Range("B10").Top
       .Width = ActiveSheet.Range("B10:C11").Width
       .Height = ActiveSheet.Range("B10:C11").Height
       .Placement = 1

    End With
    
    Set photo = ActiveSheet.Pictures.Insert(photoNameAndPath)
    With photo
       .Left = ActiveSheet.Range("C20").Left
       .Top = ActiveSheet.Range("C20").Top
       .Width = ActiveSheet.Range("C20:D21").Width
       .Height = ActiveSheet.Range("C20:D21").Height
       .Placement = 1

    End With
    
    
    Set photo = ActiveSheet.Pictures.Insert(photoNameAndPath)
    With photo
       .Left = ActiveSheet.Range("D30").Left
       .Top = ActiveSheet.Range("D30").Top
       .Width = ActiveSheet.Range("D30:E31").Width
       .Height = ActiveSheet.Range("D30:E31").Height
       .Placement = 1

    End With
    
    
    Set photo = ActiveSheet.Pictures.Insert(photoNameAndPath)
    With photo
       .Left = ActiveSheet.Range("E40").Left
       .Top = ActiveSheet.Range("E40").Top
       .Width = ActiveSheet.Range("E40:F41").Width
       .Height = ActiveSheet.Range("E40:F41").Height
       .Placement = 1

    End With
    
        Set photo = ActiveSheet.Pictures.Insert(photoNameAndPath)
    With photo
       .Left = ActiveSheet.Range("A84").Left
       .Top = ActiveSheet.Range("A84").Top
       .Width = ActiveSheet.Range("A84:B85").Width
       .Height = ActiveSheet.Range("A84:B85").Height
       .Placement = 1

    End With
    
    
    Set photo = ActiveSheet.Pictures.Insert(photoNameAndPath)
    With photo
       .Left = ActiveSheet.Range("C215").Left
       .Top = ActiveSheet.Range("C215").Top
       .Width = ActiveSheet.Range("C215:E216").Width
       .Height = ActiveSheet.Range("C215:E216").Height
       .Placement = 1

    End With
    
    
End Sub

Sub remove()

Dim s As Shape, rng As Range

    Set rng = Range("A1:A1")
    
    For Each s In ActiveSheet.Shapes
        If Intersect(rng, s.TopLeftCell) Is Nothing Then
        Else
            s.Delete
        End If
    Next s
    
     Set rng = Range("B10:B10")
    
    For Each s In ActiveSheet.Shapes
        If Intersect(rng, s.TopLeftCell) Is Nothing Then
        Else
            s.Delete
        End If
    Next s
    
      Set rng = Range("C20:C20")
    
    For Each s In ActiveSheet.Shapes
        If Intersect(rng, s.TopLeftCell) Is Nothing Then
        Else
            s.Delete
        End If
    Next s
    
    
       Set rng = Range("D30:D30")
    
    For Each s In ActiveSheet.Shapes
        If Intersect(rng, s.TopLeftCell) Is Nothing Then
        Else
            s.Delete
        End If
    Next s
    
         Set rng = Range("E40:E40")
    
    For Each s In ActiveSheet.Shapes
        If Intersect(rng, s.TopLeftCell) Is Nothing Then
        Else
            s.Delete
        End If
    Next s
    
    
    
               Set rng = Range("A84:A84")
    
    For Each s In ActiveSheet.Shapes
        If Intersect(rng, s.TopLeftCell) Is Nothing Then
        Else
            s.Delete
        End If
    Next s
    
    
           Set rng = Range("C215:C215")
    
    For Each s In ActiveSheet.Shapes
        If Intersect(rng, s.TopLeftCell) Is Nothing Then
        Else
            s.Delete
        End If
    Next s
    
    

    
End Sub

 

[MARK858]

Can't see why it is doing it but can you see if the below deletes the signature?

    Set rng = Range("A83")
   
    For Each s In ActiveSheet.Shapes
        If Intersect(rng, s.TopLeftCell) Is Nothing Then
        Else
            s.Delete
        End If
    Next s

 

[BrendanDixon]

Managed to sort it out now. I tried the document with a different signature and it worked. could not understand why that specific signature would not delete from the specific cell. I made the following change to when I insert the file into the cell and that seemed to have sorted the problem. I am guessing it is something to do with the calculations when excel inserts the picture. I suspect your idea would have worked though.

With ActiveSheet.Pictures.Insert(filselect)
.Left = Range("A84").Left
.Top = Range("A84").Top + 1
'.Width = 120
.Height = 29
End With

 

[MARK858]

Glad you got it sorted.

If you get that issue again I would run something like the below to make sure there is an intersect, obviously there should be in your case 2 A84's appear together.

Sub TestIntersect()
Dim s As Shape, Rng As Range

Set Rng = Range("A84")

    For Each s In ActiveSheet.Shapes
        Debug.Print Rng.Address
        Debug.Print s.TopLeftCell.Address

    Next s

End Sub

By the way if you want to add manual formatting to your code when posting then use the Rich code tag option rather than the VBA code tag option