Sub Общий1()

ActiveSheet.Shapes("ОбъектX 001").Delete
ActiveSheet.Shapes("ОбъектY 001").Delete
ActiveSheet.Shapes("ОбъектZ 001").Delete

Макрос1
Макрос2
Макрос3

Range("A1").Select

End Sub

Sub Макрос1()
    Dim rx, adr, fn, zd, x, y, z, zz, cnt&
    zd = [R6]
    fn = [S6]
    For Each x In ActiveSheet.Shapes
      If x.Name Like "ОбъектX*" Then x.Delete
    Next
    Set z = ActiveSheet.Shapes(zd)
    With ActiveSheet.Cells
        Set rx = .Find(fn)
        If Not rx Is Nothing Then
            adr = rx.Address
            Do
                If rx.Address <> "$S$6" Then
                    rx.Select
                    x = rx.Left + rx.Width - z.Width
                    y = rx.Top
                    z.Copy
                    ActiveSheet.Paste: cnt = cnt + 1
                    Selection.Left = x:  Selection.Name = "ОбъектX" & Format(cnt, " 000")
                End If
                Set rx = .FindNext(rx)
            Loop While rx.Address <> adr
        End If
    End With
End Sub

Sub Макрос2()
    Dim rx, adr, fn, zd, x, y, z, zz, cnt&
    zd = [R7]
    fn = [S7]
    For Each x In ActiveSheet.Shapes
      If x.Name Like "ОбъектY*" Then x.Delete
    Next
    Set z = ActiveSheet.Shapes(zd)
    With ActiveSheet.Cells
        Set rx = .Find(fn)
        If Not rx Is Nothing Then
            adr = rx.Address
            Do
                If rx.Address <> "$S$7" Then
                    rx.Select
                    x = rx.Left + rx.Width - z.Width
                    y = rx.Top
                    z.Copy
                    ActiveSheet.Paste: cnt = cnt + 1
                    Selection.Left = x:  Selection.Name = "ОбъектY" & Format(cnt, " 000")
                End If
                Set rx = .FindNext(rx)
            Loop While rx.Address <> adr
        End If
    End With
End Sub

Sub Макрос3()
    Dim rx, adr, fn, zd, x, y, z, zz, cnt&
    zd = [R8]
    fn = [S8]
    For Each x In ActiveSheet.Shapes
      If x.Name Like "ОбъектZ*" Then x.Delete
    Next
    Set z = ActiveSheet.Shapes(zd)
    With ActiveSheet.Cells
        Set rx = .Find(fn)
        If Not rx Is Nothing Then
            adr = rx.Address
            Do
                If rx.Address <> "$S$8" Then
                    rx.Select
                    x = rx.Left + rx.Width - z.Width
                    y = rx.Top
                    z.Copy
                    ActiveSheet.Paste: cnt = cnt + 1
                    Selection.Left = x:  Selection.Name = "ОбъектZ" & Format(cnt, " 000")
                End If
                Set rx = .FindNext(rx)
            Loop While rx.Address <> adr
        End If
    End With
End Sub

Option Explicit
Sub Общий()
    With Application
        .ScreenUpdating = 0: .EnableEvents = 0
        With ActiveSheet
            DuplicateShapes .[O1], .[K1], "Звездочка", _
                            .[S6], .[R6], "ОбъектX", _
                            .[S7], .[R7], "ОбъектY", _
                            .[S8], .[R8], "ОбъектZ"
        End With
        .ScreenUpdating = 1: .EnableEvents = 1
    End With
End Sub

Private Sub DuplicateShapes(ParamArray arg() As Variant)
    Dim arr() As Variant, lc As Range, c As Range, x As Shape, i&, cnt&
    For i = 0 To UBound(arg) \ 3
        For Each x In arg(i * 3).Parent.Shapes
          If x.Name Like arg(i * 3 + 2) & "*" Then x.Delete
        Next
        With arg(i * 3).Parent.UsedRange
            arr = .Formula
            Set lc = .SpecialCells(11).Offset(1, 1)
            .Replace "*" & arg(i * 3) & "*", "=" & lc.Address, xlWhole
            For Each c In lc.DirectDependents
                If c.Address <> arg(i * 3).Address Then
                    With ActiveSheet.Shapes(arg(i * 3 + 1)).Duplicate
                        cnt = cnt + 1: .Left = c.Left + c.Width - .Width
                        .Top = c.Top: .Name = arg(i * 3 + 2) & Format(cnt, " 000")
                    End With
                End If
            Next
            .Formula = arr
        End With
    Next
End Sub

ActiveSheet.Shapes("ОбъектX 001").Delete

If x.Name Like arg(i * 3 + 2) & "*" Then x.Delete

DuplicateShapes ЯчейкаСИскомымТекстом, ИмяФигуры, ПрефиксДубликатаФигуры, [...]