VBA: auto group multile pictures kept in each exce

Question

I have multiple images in each cell in column B. There are 1000 rows.

I need a VBA to "auto group" pictures available in each row. But with the below code I can't perform the action in a single cell at a time.

Sub groupimagesandshape()
' group images and shapes in each cell of column B

Sheet1.Shapes.SelectAll
Selection.Group

ActiveWorkbook.Save

End Sub

Answer 1

the shapes are in cells in column B then this code will work.

Sub test()
    Dim shp As Shape, shpU As Shape
    Dim vArray(), vR()
    Dim Ws As Worksheet, rng As Range
    Dim n  As Long, k As Integer
    Dim v As Variant

    Set Ws = ActiveSheet

    Ws.Shapes.SelectAll
    Selection.Ungroup

    For Each shp In Ws.Shapes
        n = n + 1
        ReDim Preserve vArray(1 To n)
        vArray(n) = shp.Name
    Next shp
    For Each rng In Ws.Range("b1:b1000")
        k = 0
        For Each v In vArray
            If Not Intersect(Ws.Shapes(v).TopLeftCell, rng) Is Nothing Then
                k = k + 1
                ReDim Preserve vR(1 To k)
                vR(k) = v
            End If
        Next v
        If k > 1 Then
            Ws.Shapes.Range(vR).Group
        End If
    Next rng
End Sub