Deleting Pictures From In Merged Cell

[muhammad susanto]

hi all...
i have macro code to delete all picture (3 pict) in a sheet in condition MERGED cell..
the picture in cell B6 (no merge cell), C6:D6 (merged cell) and E6:F6 (merged cell)
here this code :

Sub deletePicturesFromMergedCells()
    Dim sh As Shape, ws As Worksheet
    Dim rng As Range

    Set ws = Worksheets......( [B]" i want name of sheet is random)"[/B])

    For Each sh In ws.Shapes
        'if shape is picture
        If sh.Type = msoPicture Or sh.Type = msoLinkedPicture Then
            'get entire range where picture placed
            Set rng = ws.Range(sh.TopLeftCell, sh.BottomRightCell)
            'if picture is in range A8 (with megred cells) then delete it
            If Not Intersect(rng, ws.Range("B6:F6").MergeArea) Is Nothing Then
                sh.Delete
            End If
        End If
    Next sh
End Sub

note :
name of sheet are random name
this macro not work for merged cell...
how to modify that code so work in merged cell

thank for your helping
.sst

 

[JoeMo]

Assuming your merged area is B6:F6, maybe something like this:

Sub DeletePicFromMergedCell()
Dim Pic As Picture, rng As Range
For Each Pic In ActiveSheet.Pictures
    Set rng = Range(Pic.TopLeftCell.Address, Pic.BottomRightCell.Address)
    If Not Intersect(rng, Range("B6:F6")) Is Nothing Then
        Pic.Delete
    End If
Next Pic
End Sub

 

[jolivanes]

Or if it is just the top left cell:

Sub Or_Maybe()
Dim pic As Picture
    For Each pic In ActiveSheet.Pictures
        If pic.TopLeftCell.MergeCells Then pic.Delete
    Next pic
End Sub

 

[muhammad susanto]

Or if it is just the top left cell:

Sub Or_Maybe()
Dim pic As Picture
    For Each pic In ActiveSheet.Pictures
        If pic.TopLeftCell.MergeCells Then pic.Delete
    Next pic
End Sub

hi Jolivanse...your code not fully work cause 1 picture in cell B6 can't delete..

 

[muhammad susanto]

Assuming your merged area is B6:F6, maybe something like this:

Sub DeletePicFromMergedCell()
Dim Pic As Picture, rng As Range
For Each Pic In ActiveSheet.Pictures
    Set rng = Range(Pic.TopLeftCell.Address, Pic.BottomRightCell.Address)
    If Not Intersect(rng, Range("B6:F6")) Is Nothing Then
        Pic.Delete
    End If
Next Pic
End Sub

hi JoeMo, thanks working well

 

[JoeMo]

hi JoeMo, thanks working well

You are welcome - thanks for the reply.