Another one just for fun -

Option Explicit
Type CO_ORDS
xl As Single
xr As Single
yt As Single
yb As Single
End Type

Sub RandomShapes()
Dim i&, x#, y#
ActiveSheet.Rectangles.Delete
For i = 1 To 50
x = Rnd() * 300
y = Rnd() * 200
' ActiveSheet.Shapes.AddShape 1, x, y, 90, 60
ActiveSheet.Rectangles.Add x, y, 90, 60
Next
End Sub

Sub Unjumble()
Dim bH As Boolean, bV As Boolean, bRedo As Boolean
Dim A As CO_ORDS, B As CO_ORDS
Dim minGap As Single
Dim i As Long, j As Long, nCnt As Long
Dim shps As Shapes

minGap = 3
If minGap < 0.75 Then minGap = 0.75

Set shps = ActiveSheet.Shapes

bRedo = True
Do Until bRedo = False
bRedo = False
For i = 2 To shps.Count
GetCoordinates shps(i), B
For j = 1 To i - 1
GetCoordinates shps(j), A
bH = (B.xl = A.xl And B.xl <= A.xr) Or (A.xl = B.xl And A.xl <= B.xr)
bV = (B.yt = A.yt And B.yt <= A.yb) Or (A.yt = B.yt And A.yt <= B.yb)
If bH And bV Then
bRedo = True
If Abs(A.xl - B.xl) Abs(A.yt - B.yt) Then
B.yt = A.yb + minGap: shps(i).Top = B.yt
Else
B.xl = A.xr + minGap: shps(i).Left = B.xl
End If
End If
bH = False: bV = False
Next
Next
Loop
End Sub

Function GetCoordinates(sh As Shape, pos As CO_ORDS)
With sh
pos.xl = .Left
pos.xr = pos.xl + .Width
pos.yt = .Top
pos.yb = pos.yt + .Height
End With
End Function

This could be adapted as a function to move only the last (top) shape and/or
return suggested left/top.

Regards,
Peter T



"SpaceCamel" wrote in message
...
I am automatically creating shapes within cells on a sheet but do not want
them overlaping. I do not know how many there will be within each cell.

Is the a way to determine if a new shape will overlap an existing one so
it
can be shifted down out of the way?

Thanks,