Option Explicit

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)

Dim ss As Shapes
Dim s As Shape
Dim s2 As Shape
Dim sh As Shape
Dim sh2 As Shape
Dim redPoint As Shape
Dim r As Range, r2 As Range
Dim sourse As String
Dim destX As Single, destY As Single
Dim targetX As Single, targetY As Single
Dim sr As Shapes
Dim ids As Variant

Public Sub CloneAndMode2()
    Application.ScreenUpdating = False
    On Error Resume Next
    Set r = [AI10:AI16]: Set r2 = [AJ10:AJ16]
    Set ss = ActiveSheet.Shapes
    ReDim ids(1 To 1)
    For Each s In ss
        If s.Type = msoGroup Then
            For Each s2 In s.GroupItems
                If s2.Name Like "Приемный узел*" Then
                Call Ungroup2(s)
                Call moveshape2(s2)
                Call Group2
                End If
            Next
        Else
            If s.Name Like "Приемный узел*" Then
                Call moveshape2(s)
            End If
        End If
    Next
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Private Sub moveshape2(ByRef sh As Shape)
    sourse = Cells(r.Find(sh.Name).Row, r.Find(sh.Name).Column + 1).Value
    ActiveSheet.Shapes(sourse).Copy
    Sleep 200
    ActiveSheet.Paste
    Set sh2 = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    sh2.Name = sh2.Name & "_" & (Time * 1000)
    Set redPoint = sh2.GroupItems("redPoint")
    targetX = sh2.Left + 0.5 * sh.Width
    targetY = sh2.Top + 0.5 * sh.Height
    destX = sh.Left - (redPoint.Left + 0.5 * redPoint.Width) + targetX
    destY = sh.Top - (redPoint.Top + 0.5 * redPoint.Height) + targetY
    sh2.Top = destY
    sh2.Left = destX
End Sub

Private Sub Ungroup2(ByRef sh As Shape)
    Dim sh3 As Shape
    Dim n As Long
    n = 1
    For Each sh3 In sh.GroupItems
        ReDim Preserve ids(1 To n)
        ids(n) = sh3.ID
        n = n + 1
    Next
    sh.Ungroup
End Sub

Private Sub Group2()
    Dim i As Long
    Dim ssh As Shape
    For i = 1 To UBound(ids)
        For Each ssh In ActiveSheet.Shapes
            If ssh.ID = ids(i) Then
                If i = 1 Then
                    ssh.Select
                Else
                    ssh.Select Replace:=False
                End If
            End If
        Next
    Next
    ActiveWindow.Selection.ShapeRange.Group
    Erase ids
End Sub