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 CloneAndMode()
    Application.ScreenUpdating = False
    Set r = [AB10:AB16]: Set r2 = [AC10:AC16]
    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 Ungroup(s)
                   Call moveshape(s2)
                   Call Group
                End If
            Next
        Else
            If s.Name Like "Приемный узел*" Then
                Call moveshape(s)
            End If
        End If
    Next
    Application.ScreenUpdating = True
End Sub
''''''''''''''''''''''
Private Sub moveshape(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 Ungroup(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 Group()
    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
''''''''''''''''''''''

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Const SW_SHOWNORMAL = 1&
Public Status As Integer 

''''''''''''''' Активирует окно по названию '''''''''''''''''''''''''''''''''''''
Sub main()
Dim hwnd&
hwnd = FindWindow(vbNullString, "НАЗВАНИЕ ОКНА")
If hwnd <> 0 Then 'Если открыто
    ShowWindow hwnd, SW_SHOWNORMAL
Else 'Если нет
    Exit Sub
End If
End Sub 

'Позиция мыши
Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
' Create custom variable that holds two integers
Type POINTAPI
   Xcoord As Long
   Ycoord As Long
End Type

Sub GetCursorPosDemo()
Dim llCoord As POINTAPI
' Get the cursor positions
GetCursorPos llCoord
' Display the cursor position coordinates
MsgBox "X Position: " & llCoord.Xcoord & vbNewLine & "Y Position: " & llCoord.Ycoord
End Sub

'Кликаем мышью
Public Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare PtrSafe Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10

Public Sub SingleClick(Optional ByVal x = 300, Optional ByVal y = 300)
  SetCursorPos x, y 'x and y position
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

Public Sub DoubleClick(Optional ByVal x = 300, Optional ByVal y = 300)
  'Double click as a quick series of two clicks
  SetCursorPos x, y 'x and y position
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub

Public Sub RightClick(Optional ByVal x = 300, Optional ByVal y = 300)
  'Right click
  SetCursorPos x, y 'x and y position
  mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
  mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
End Sub

SendKeys "^c"
SendKeys "^v" 

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