This works in finding pictures that have the same TopLeftCell.Address.
Code:
'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
Reply With Quote
Bookmarks