如何检查单元格是否有图片？

Question

In Excel, I want to check if a specific cell for instance "C12" has a picture?
How could I do this?

Answer 1

为此，您可以循环访问工作表的 Shapes 集合，查找.TopLeftCell与目标范围具有相同地址的形状。

Answer 2

The simplest solution is to create a function that will return 1 if image exists in cell, 0 if it does not. This only works for individual cells and needs modified for multi-cell ranges.

Function CellImageCheck(CellToCheck As Range) As Integer
' Return 1 if image exists in cell, 0 if not

    Dim wShape As Shape

    For Each wShape In ActiveSheet.Shapes
        If wShape.TopLeftCell = CellToCheck Then
            CellImageCheck = 1
        Else
            CellImageCheck = 0
        End If
    Next wShape

End Function

This code can then be run using:

Sub testFunction()

    If CellImageCheck(Range("B6")) Then
        MsgBox "Image exists!"
    Else
        MsgBox "Image does not exist"
    End If

End Sub

Answer 3

I had a situation where I wanted to delete pictures (In my case charts) from selected cells on a worksheet and leave others in place therefore removing all pictures was not an option. I've left behind some debugging and also some extra code to tell the user what is going on.

Public Sub RemoveUnWantedGraphs()

    Dim shp As Shape
    Dim rangeToTest As Range
    Dim c As Range
    Dim shpList

    'Set the rangeToTest variable to the selected cells
    Set rangeToTest = Selection

    'Loop Over the the selected cells
    For Each c In rangeToTest


        'Inner loop to iterate over the shapes collection for the activesheet
        Set shpList = ActiveSheet.Shapes
        For Each shp In shpList

            Application.StatusBar = "Analysing:- " + c.Address + " Graphs To Find:- " & shpList.Count


            'If the address of the current cell and the address
            'of the shape are the same then delete the shape
            If c.Address = shp.TopLeftCell.Address Then

                Debug.Print "Deleting :- " & shp.Name
                shp.Delete

                DoEvents
            End If

        Next shp

    Next c

    Application.StatusBar = ""

    MsgBox "All Shapes In Range Deleted"

End Sub

Answer 4

This is quite an old thread so don't know whether my post will help anybody, but I encountered a similar problem today and after some thinking, derived solution.

I have first stored all range addresses where object exists, to an array and then in the second part of the code, checked each cell address in my selected range for the object against each element in array and carried out execution of tagging to an offset cell if array element address matches active cell address in selected range. Hope, it helps. Here is the code:

Option Explicit
Sub tagging()
Dim rng As Range, shp As Shape, n As Integer, arr() As String, m As Integer, arrm As Variant
m = 1
n = ActiveSheet.Shapes.Count
ReDim arr(n)
For Each shp In ActiveSheet.Shapes
    arr(m) = shp.TopLeftCell.Address
    m = m + 1
Next
   For Each rng In Selection
       m = 1
       For Each arrm In arr
           If rng.Address = arr(m) Then
              rng.Offset(0, 30).Value = "Yes"
              Exit For
           Else
              rng.Offset(0, 30).Value = "No"
           End If
                If m < n Then
                   m = m + 1
                Else
                   Exit For
                End If
      Next
  Next
End Sub

Answer 5

For Each wShape In ActiveSheet.Shapes
If (wShape.Type <> 13) Then wShape.Delete ' If the shape doesn't represent a Picture,     ' delete
Next wShape

Answer 6

Juhi's approach helped me. I think there's an implied need in the original question to apply this to multiple cells or a contiguous range or even a whole sheet. In such a case, it's desirable not to consider each cell separately and loop through every shape in the sheet repeatedly for all the cells of interest.

I've changed the functionality a little to remove the nested loop and enter text into all the cells that contain a shape. This is optimised for my immediate need where the source data is a 4x40 cell region where the cells either contain a Shape or nothing at all. My method doesn't enter 'no' for the cells that contain no shape, but it's easy to enter that into the blank cells at the end.

Sub MarkCellsWithShapes()

    Dim rng As Range, shp As Shape, n As Integer, arr() As String, m As Integer, arrm As Variant

    n = ActiveSheet.Shapes.Count
    ReDim arr(n)
    
    m = 1

    For Each shp In ActiveSheet.Shapes
        arr(m) = shp.TopLeftCell.Address
        Range(arr(m)) = "Yes"
        m = m + 1
    Next

End Sub

If you need to work in a specific range rather than a whole sheet, you could make the 'yes' instruction conditional (see VBA test if cell is in a range for tips on that).