Sub Макрос1()
    Dim ws As Worksheet
    Dim h As Range
    Dim nREnd As Integer
    Dim arrN()
   
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    With ws.UsedRange
        Set h = .Range(.Cells(1, 1), .Cells(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1)).Find(What:="Название")

        With h
            nRIn = .Row + 1
            nCIn = .Column
            nREnd = .End(xlDown).Row
        End With
        
        Set h = Nothing
    End With
    
    i = 0
    For r = 6 To nREnd
        If i = 0 Then
            ReDim arrN(2, i)
        Else
            ReDim Preserve arrN(2, i)
        End If
        
        With ws
            arrN(0, i) = .Cells(r, nCIn).Text
            arrN(1, i) = .Cells(r, nCIn + 1).Interior.Color
            arrN(2, i) = .Cells(r, nCIn + 2).Value
        End With
        i = i + 1
    Next r
    
    i = 0
    For Each sh In ActiveSheet.Shapes
        n = sh.Name
        For i = LBound(arrN, 2) To UBound(arrN, 2)
            If arrN(0, i) = n Then
                'ws.Shapes(n).Select False
                
                zv = arrN(1, i)
                rr = arrN(2, i)
                MsgBox "Цвет = " & zv & Chr(10) & "Радиус = " & rr, vbInformation + vbOKOnly, "" & n
                
                With sh
                    'Меняем высоту и ширину фигуры
                    '.Height = 150
                    '.Width = 100
                    'Меняем цвет фигуры
                    .Fill.ForeColor.RGB = zv
                End With
                Exit For
            End If
        Next i
    Next
End Sub