Identifying cells with two or more images in them

[frisbee]

This works in finding pictures that have the same TopLeftCell.Address.

'Finds images that have the same TopLeftCell.Address,
'Then reports with a message box and selects the cell
Sub First_Overlapping_Images()
Dim myArray As Variant
Dim myString As String
Dim AryLen As Long
Dim pic As Shape
Dim i As Long, j As Long 'pointers

'Go through each picture in ActiveSheet.Shapes and store the TopLeftCell.Address string values in a comma delimited string
    For Each pic In ActiveSheet.Shapes
      If pic.Type = msoPicture Then
        myString = myString & ";" & pic.TopLeftCell.Address
      End If
    Next pic
'Remove first delimiter from string (;)
    myString = Right(myString, Len(myString) - 1)
'Create an array with the Split() function
    myArray = Split(myString, ";")
    AryLen = Application.CountA(myArray)
'Loop through array with two pointers
    If AryLen > 1 Then
      For i = 0 To AryLen - 1
        For j = 0 To AryLen - 1
          If i <> j Then 'Skips if pointers are equal
            If myArray(i) = myArray(j) Then
              MsgBox "First double images found at cell " & myArray(i)
              Range(myArray(i)).Select
              Exit Sub
            End If
          End If
        Next j
      j = 0
      Next i
    MsgBox "No overlapping images found"
    End If
End Sub

End Sub