VBA grouping shapes by position

[bluphoto]

Can anyone help me with setting up and adding shapes to groups depending on their position on the worksheet. They are all pasted dynamically and regularly deleted and recreated, so usign their ID or name is difficult. They are a mixture of textboxes, arrows and pictures.

Hopefully the below code snippet will let you see what I'm trying to do

Sub groupshapes()
Dim myshape As Object
' groups:
'  1   2   3
'  4   5   6

Group = 0

For Each Object In ActiveSheet
    Select Case Object.Left
    Case 0 To Range("P1").Left: Group = 1
    Case Range("Q1").Left To Range("AF1").Left: Group = 2
    Case Range("AH1").Left To Range("AV1").Left: Group = 3
    End Select
    If Object.Top > Range("A27").Left Then Group = Group + 3
    
    'Add object to relevant group - no idea how :)
Next

End Sub

[StephenR]

Could you post a sample workbook with just a few shapes to illustrate?

[bluphoto]

of course. sorry... (if I can work out how)

sample.xlsm

[bluphoto]

This still doesn't work (object doesn't support this property or method), but I think I'm getting there... Any help appreciated...

(I think my problem might be somthing around "Object.Name")

Sub groupshapes()
Dim myshape As Object
' groups:
'  1   2   3
'  4   5   6
Dim g(1 To 6) As String

Group = 0
'Cycle though all objects and compare their xy with specific cells xy.
'Build six strings of names (separated with "|") based on the group number
For Each Object In ActiveSheet
    Select Case Object.Left
    Case 0 To Range("P1").Left: Group = 1
    Case Range("Q1").Left To Range("AF1").Left: Group = 2
    Case Range("AH1").Left To Range("AV1").Left: Group = 3
    End Select
    If Object.Top > Range("A27").Left Then Group = Group + 3
    g(Group) = g(Group) & Object.Name & "|"
Next

'Split each of the six strings into arrays and create six object groups.
For n = 1 To UBound(g)
    If Right(g(n), 1) = "|" Then g(n) = Left(g(n), Len(g(n)) - 1) 'remove trailing "|"
    ActiveSheet.Shapes.Range(Split(g(n), "|")).ShapeRange.Group 'group objects
Next n
End Sub

[StephenR]

Try this. I'm out of time now but will take a look tomorrow if problems persist. I got a strange error on the .Left lines

Sub groupshapes()

Dim myshape As Shape, v1(), v2(), v3(), i As Long, j As Long, k As Long
Dim a, b, c, d, e

a = Range("P1").Left
b = Range("Q1").Left
c = Range("AF1").Left
d = Range("AH1").Left
e = Range("AV1").Left

For Each myshape In ActiveSheet.Shapes
    myshape.Select
    Select Case myshape.Left
    Case 0 To a
        i = i + 1
        ReDim Preserve v1(1 To i)
        v1(i) = myshape.Name
    Case b To c
        j = j + 1
        ReDim Preserve v2(1 To j)
        v2(j) = myshape.Name
    Case d To e
        k = k + 1
        ReDim Preserve v3(1 To k)
        v3(k) = myshape.Name
    End Select
    'If Object.Top > Range("A27").Left Then Group = Group + 3 - have not catered for this line as not sure what it should do
Next myshape

With ActiveSheet.Shapes
    On Error Resume Next
    .Range(v1).Group
    .Range(v2).Group
    .Range(v3).Group
End With

End Sub