PDA

View Full Version : Identifying cells with two or more images in them



frisbee
04-28-2020, 04:38 PM
There are times when a cell has two or more images in them, one on top of the other and it is very difficult to know where they are. Having a macro to identify and activate those cells and notify how many images are in that cell would be fantastic so the user can manually correct the problem.

Thanks in advance

https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)
https://www.eileenslounge.com/viewtopic.php?f=44&t=40455&p=313035#p313035 (https://www.eileenslounge.com/viewtopic.php?f=44&t=40455&p=313035#p313035)
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312889#p312889 (https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312889#p312889)
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312886#p312886 (https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312886#p312886)
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312752#p312752 (https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312752#p312752)
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312734#p312734 (https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312734#p312734)
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312727#p312727 (https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312727#p312727)
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312724#p312724 (https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312724#p312724)
https://www.eileenslounge.com/viewtopic.php?f=44&t=40374&p=312535#p312535 (https://www.eileenslounge.com/viewtopic.php?f=44&t=40374&p=312535#p312535)
https://www.eileenslounge.com/viewtopic.php?p=312533#p312533 (https://www.eileenslounge.com/viewtopic.php?p=312533#p312533)
https://www.eileenslounge.com/viewtopic.php?f=44&t=40373&p=312499#p312499 (https://www.eileenslounge.com/viewtopic.php?f=44&t=40373&p=312499#p312499)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9xpn-GDkL3o (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9xpn-GDkL3o)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg.9zYoeePv8sZ9zYqog9KZ 5B (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg.9zYoeePv8sZ9zYqog9KZ 5B)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9zYlZPKdO pm (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9zYlZPKdO pm)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

frisbee
04-30-2020, 04:53 PM
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