VBA (Excel 2007) Shape Handling and Color Change

Thank you.

It works fine. In my work sheet nearly 10 types of shapes of about 50 to 80 numbers are present. So, without selecting the shapes how it is possible?

Change the script to point to the shapes via shapes.Count

The following will check all the shapes:

Dim scount As Integer

For scount = 1 To ActiveSheet.shapes.Count
shp1x = ActiveSheet.shapes(scount).Left

<etc.>
Next scount

I would also use some "do While" loops if you want to check against all the shapes.

Found some time to play:

Still very rough but you'll get the idea.

Changed it to only change the line color since some shapes does not have the Fill property - you'll have to add some kind of check if you wish to change the fill color for the shapes that does have Fill.

Sub CheckPosition()
Dim shp1x As Integer, shp1y As Integer, shp1w As Integer, shp1h As Integer
Dim shp2x As Integer, shp2y As Integer, shp2w As Integer, shp2h As Integer
Dim scount As Integer, tcount As Integer, touch As Boolean

'Reset all shapes color before checking
For scount = 1 To ActiveSheet.shapes.Count
ActiveSheet.shapes(scount).Line.ForeColor.RGB = RGB(0, 255, 0)
Next scount

For scount = 1 To ActiveSheet.shapes.Count
shp1x = ActiveSheet.shapes(scount).Left
shp1y = ActiveSheet.shapes(scount).Top
shp1w = ActiveSheet.shapes(scount).Width
shp1h = ActiveSheet.shapes(scount).Height
For tcount = 1 To ActiveSheet.shapes.Count 'test against all other shapes
If tcount <> scount Then 'do not test against self
shp2x = ActiveSheet.shapes(tcount).Left
shp2y = ActiveSheet.shapes(tcount).Top
shp2w = ActiveSheet.shapes(tcount).Width
shp2h = ActiveSheet.shapes(tcount).Height
If (shp1x <= (shp2x + shp2w)) And ((shp1x + shp1w) >= shp2x) And _
(shp1y <= (shp2y + shp2h)) And ((shp1y + shp1h) >= shp2y) Then
ActiveSheet.shapes(tcount).Line.ForeColor.RGB = RGB(255, 0, 0)
touch = True
End If
End If
Next tcount
If touch Then 'this shape was touching one or more others
ActiveSheet.shapes(scount).Line.ForeColor.RGB = RGB(255, 0, 0)
Else
ActiveSheet.shapes(scount).Line.ForeColor.RGB = RGB(0, 255, 0)
End If
touch = False
Next scount


Application.OnTime Now + TimeValue("00:00:03"), "CheckPosition"
End Sub