Sub ВыводФотоФигур()

Dim itx As Long
    Application.ScreenUpdating = False
    For itx = ActiveSheet.Shapes.Count To 1 Step -1
        If Not Intersect(ActiveSheet.Shapes(itx).TopLeftCell, Columns("I:BJF")) Is Nothing Then
            ActiveSheet.Shapes(itx).Delete
        End If
    Next itx
    ActiveSheet.Range("I1:BJF50").ClearContents
  
        

    Dim Ws As Worksheet, i%, FR As Range, adr$, f$, a$, ms, str&, col&
    str = 2: col = 9
    For i = 5 To Cells(Rows.Count, 3).End(xlUp).Row
        f = Cells(i, 3).Value
        For Each Ws In Sheets
            If Ws.Name <> "Поиск" And Ws.Name <> "Лист4" Then
                Set FR = Ws.Cells.Find(f)
                If Not FR Is Nothing Then
                    Cells(str, col) = Ws.Name & "!" & FR.Address
                    Cells(str + 1, col) = FR
                    Макрос1 Cells(str, col).Value, col
                    col = col + 4
                    'adr = adr & " " & Ws.Name & "!" & FR.Address
                    '---цикл по следующим найденным ячейкам
                    a = FR.Address    '---запоминаем адрес первой найденной ячейки
                    Do
                        Set FR = Ws.Cells.FindNext(FR)
                        If FR.Address = a Then Exit Do
                        col = col + 4
                        Cells(str, col) = Ws.Name & "!" & FR.Address
                        Cells(str + 1, col) = FR
                        Макрос1 Cells(str, col).Value, col
                        'adr = adr & " " & Ws.Name & "!" & FR.Address
                    Loop
                    '-----------
                End If
                '                If adr <> "" Then
                '                    ms = Split(Mid(adr, 2, 1000))
                '                    Cells(i, 5).Resize(, UBound(ms) + 1) = ms
                '                End If
            End If
        Next
        'Cells(i, 5) = adr 'если в одну
        'если один адрес - одна ячейка
        'ms = Split(Mid(adr, 2, 1000))
        'Cells(i, 5).Resize(, UBound(ms) + 1) = ms
        '-------------------------
        'adr = ""
    Next
    
    Application.ScreenUpdating = True
    Range("A1").Select
End Sub

Sub Макрос1(ByVal adr As String, ByVal col As Long)
    'adr = Лист5.[i2]
    If adr = "" Then Exit Sub
    shi = Split(adr, "!")(0)
    Mn = 0
    Set cl = Range(adr) '[M16]
    clleft = cl.Left: cltop = cl.Top
    
    For Each Sh In Sheets(shi).Shapes
        shLeft = Sh.Left
        shtop = Sh.Top
        d = (Abs(clleft - shLeft) ^ 2 + Abs(cltop - shtop) ^ 2) ^ 0.5
        If Mn = 0 Then
        Mn = d: f = Sh.Name
        ElseIf Mn > d Then Mn = d: f = Sh.Name
        End If
    Next
    
    Лист22.Cells(1, col) = f
    
    Sheets(shi).Shapes(f).Copy  'Select
    Лист22.Cells(5, col).Select
    ActiveSheet.Paste
    
End Sub

Sub ОчисткаДиапазона()
Dim itx As Long
    Application.ScreenUpdating = False
    For itx = ActiveSheet.Shapes.Count To 1 Step -1
        If Not Intersect(ActiveSheet.Shapes(itx).TopLeftCell, Columns("I:BJF")) Is Nothing Then
            ActiveSheet.Shapes(itx).Delete
        End If
    Next itx
    ActiveSheet.Range("I1:BJF50").ClearContents
    End Sub