any easy fast possible way to group all these business cards separately

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53

Sub group_on_selected_rectangles_And_Curve_Repair()
    Dim srSelection As ShapeRange, srRectangles As ShapeRange
    Dim sRect As Shape, sShapes As ShapeRange, pCl As PowerClip
    Dim sRect1 As Shape, pClSh As ShapeRange
    
    Set srSelection = ActiveSelectionRange
    If srSelection.Shapes.Count > 1 Then MsgBox "Please only select one shape.": Exit Sub

    On Error GoTo ErrHandler
    
    ActiveDocument.BeginCommandGroup "Group objects on selected rectangles"
    EventsEnabled = False
    Optimization = True
    
    Set srRectangles = ActivePage.Shapes.FindShapes(Query:="@width = {" & srSelection(1).SizeWidth & " in } and @height ={" & srSelection(1).SizeHeight & " in }")
    
    For Each sRect In srRectangles
        On Error Resume Next
          Set pCl = sRect.PowerClip
        On Error GoTo 0
        If Not pCl Is Nothing Then
          If pCl.Parent.Type = cdrCurveShape Then
                Set pClSh = pCl.Shapes.All
                pCl.ExtractShapes
                Set sRect1 = ActiveLayer.CreateRectangleRect(pCl.Parent.BoundingBox)
                sRect1.Outline.Color = pCl.Parent.Outline.Color
                pCl.Parent.Delete
                pClSh.AddToPowerClip sRect1
                ActivePage.SelectShapesFromRectangle sRect1.LeftX, sRect1.BottomY, sRect1.RightX, sRect1.TopY, False
                ActiveSelectionRange.Group
          Else
                ActivePage.SelectShapesFromRectangle sRect.LeftX, sRect.BottomY, sRect.RightX, sRect.TopY, False
                ActiveSelectionRange.Group
          End If
        Else
            ActivePage.SelectShapesFromRectangle sRect.LeftX, sRect.BottomY, sRect.RightX, sRect.TopY, False
            ActiveSelectionRange.Group
        End If
            
    Next sRect

ExitSub:
    ActiveDocument.ClearSelection
    Optimization = False
    EventsEnabled = True
    ActiveDocument.EndCommandGroup
    Refresh
    Exit Sub

ErrHandler:
    MsgBox "Error occurred: " & Err.Description
    Resume ExitSub
End Sub