Is there a way to group objects from different layers together and have them stay on their original layers?

Sub GroupShapeRange() 'group shapes from many layers align then ungroup back to respective layers

   Dim sr As ShapeRange, s As Shape

   Set sr = ActiveSelectionRange

   For Each s In sr

   s.Name = (s.Layer.Name)

   Next s

   ActiveSelection.Group

End Sub

----------------------------------------------------------------------

Sub UngroupMoveToRespectiveLayers()

   Dim sr As ShapeRange, s As Shape

   Set sr = ActiveSelectionRange

   sr.Ungroup

   For Each s In sr

   s.Layer = ActivePage.Layers(s.Name)

   Next s

End Sub

I like your idea here, Myron.

If you wanted to preserve the Name of each shape, you could store the "layer it came from" information as custom data associated with the shape.

Sub GroupShapeRange() 'group shapes from many layers align then ungroup back to respective layers

Dim sr As ShapeRange, s As Shape
    
    Set sr = ActiveSelectionRange
    
    If ActiveDocument.DataFields.IsPresent("Original_Layer") = False Then
        ActiveDocument.DataFields.Add "Original_Layer", "General"
    End If

    For Each s In sr
        s.ObjectData("Original_Layer") = s.Layer.Name
    Next s

    ActiveSelection.Group

End Sub

----------------------------------------------------------------------

Sub UngroupMoveToRespectiveLayers()

Dim sr As ShapeRange, s As Shape

    If ActiveDocument.DataFields.IsPresent("Original_Layer") = False Then
        MsgBox "No custom data field is present for recording original layer information, so this macro is not applicable."
        Exit Sub
    End If
       
    Set sr = ActiveSelectionRange
    
    sr.Ungroup
    
    For Each s In sr
       
        If s.ObjectData("Original_layer") = "" Then
            MsgBox "No original layer was recorded for this shape."
        Else
            s.MoveToLayer ActivePage.Layers((s.ObjectData("Original_Layer")))
            s.ObjectData("Original_layer") = ""
        End If
       
    Next s

End Sub