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

Sub group_on_selected_rectangles()

Dim srRectangles As ShapeRange
Dim sRect As Shape

    On Error GoTo ErrHandler
    
    ActiveDocument.BeginCommandGroup "Group objects on selected rectangles"
    EventsEnabled = False
    Optimization = True
    
    Set srRectangles = ActiveSelectionRange
    
    For Each sRect In srRectangles
       ActivePage.SelectShapesFromRectangle sRect.LeftX, sRect.BottomY, sRect.RightX, sRect.TopY, False
       ActiveSelectionRange.Group
    Next sRect

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

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