Bulk select cells with inserted images in Microsoft Excel

Question

How do I bulk select cells which contain images in Microsoft Excel? The images are not objects so the find and select objects method does not work. I believe the images were inserted into the cells. I need to bulk select the cells containing images and then delete them (an image is not a data cell for my purposes). Selecting blank cells in find and select also doesn't work as the cell is not blank (it contains an image). In this example the yellow cells all need to be deleted and data moved up.

Answer 1

Option Explicit

Sub Example_InsertPicture()
Dim FName As String
Dim i As Long, j As Long, k As Long, n As Long, S As Long
Dim Where As Range, This As Range

'We have to be sure that cells are selected
If Not TypeOf Selection Is Range Then
MsgBox "Select some cells where you want to insert the pictures and try again.", vbInformation, "Example_InsertPicture"
Exit Sub
End If

With Application.FileDialog(msoFileDialogFilePicker)
'Allow only pictures
.Filters.Clear
.Filters.Add "Pictures", "*.bmp;*.jpg;*.jpeg;*.png;*.gif"
'Allow more then one picture to be inserted
.AllowMultiSelect = True
'Done if the user abort the dialog
If Not .Show Then Exit Sub

'Multiple pictures into the areas?  
If .SelectedItems.Count > Selection.Areas.Count Then  
  Do  
    n = Application.InputBox("How many pictures per area?", "Example\_InsertPicture", .SelectedItems.Count \ Selection.Areas.Count, Type:=2)  
    If n = 0 Then Exit Sub  
  Loop Until n > 0  
Else  
  n = 1  
End If  
 
'Perform max. possible pictures  
For i = 1 To Selection.Areas.Count  
  Set Where = Selection.Areas(i)  
  'Divide horizontally or vertically  
  If Where.Height > Where.Width Then  
    S = Where.Rows.Count \ n  
    For j = 1 To n  
      'Picture available?  
      k = k + 1  
      If k > .SelectedItems.Count Then Exit Sub  
      'Where to place  
      Set This = Where.Resize(S).Offset((j - 1) \* S)  
      'Insert into the sheet  
      InsertPicture .SelectedItems(k), This  
    Next  
  Else  
    S = Where.Columns.Count \ n  
    For j = 1 To n  
      'Picture available?  
      k = k + 1  
      If k > .SelectedItems.Count Then Exit Sub  
      'Where to place  
      Set This = Where.Resize(, S).Offset(, (j - 1) \* S)  
      'Insert into the sheet  
      InsertPicture .SelectedItems(k), This  
    Next  
  End If  
Next  

End With
End Sub

Function InsertPicture(ByVal FName As String, ByVal Where As Range, _
Optional ByVal LinkToFile As Boolean = False, _
Optional ByVal SaveWithDocument As Boolean = True, _
Optional ByVal LockAspectRatio As Boolean = True) As Shape
'Inserts the picture file FName as link or permanently into Where
Dim S As Shape, SaveScreenUpdating, SaveCursor
SaveCursor = Application.Cursor
SaveScreenUpdating = Application.ScreenUpdating
Application.Cursor = xlWait
Application.ScreenUpdating = False
With Where
'Insert in original size
Set S = Where.Parent.Shapes.AddPicture( _
FName, LinkToFile, SaveWithDocument, .Left, .Top, -1, -1)
'Keep the proportions?
S.LockAspectRatio = LockAspectRatio
'Scale it to fit the cell
S.Width = .Width
If S.Height > .Height Or Not LockAspectRatio Then S.Height = .Height
'Move it to the middle of the cells
If S.Width < Where.Width Then S.Left = Where.Left + (Where.Width - S.Width) / 2
If S.Height < Where.Height Then S.Top = Where.Top + (Where.Height - S.Height) / 2
End With
Set InsertPicture = S
Application.Cursor = SaveCursor
Application.ScreenUpdating = SaveScreenUpdating
End Function