adr = sh.TopLeftCell.Address

    For Each sh In ActiveSheet.Shapes
        n = sh.Name
        If sz.exists(n) Then
            zv = sz(n) 'цвет
            rr = sr(n) 'радиус
            x0 = sh.Left + sh.Width / 2 ' центр х
            y0 = sh.Top + sh.Height / 2 ' центр у

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
'==--==
                    Dim k As Range
                    Set k = .TopLeftCell
                    
                    Y = k.Row
                    X = k.Column
                    For r = Y - rr To Y + rr
                        For c = X - rr To X + rr
                        
                            ri = Abs(r - Y)
                            ci = Abs(c - X)
                        
                            If ri * ri + ci * ci <= rr * rr Then
                                If r > 6 And r < 33 And c > 9 And c < 40 Then ' границы поля
                                    'красим
                                    ws.Cells(r, c).Interior.Color = zv
                                End If
                            End If
                        Next c
                    Next r
'==--==
                End With
                Exit For
            End If
        Next i
    Next
End Sub

                    Y = k.Row
                    X = k.Column

If r > 6 And r < 33 And c > 9 And c < 40 Then ' границы поля

x0 = sh.Left + sh.Width / 2 ' центр х
y0 = sh.Top + sh.Height / 2 ' центр у

x0 = sh.Left + sh.Width / 2 ' центр х
y0 = sh.Top + sh.Height / 2 ' центр у

x0 = sh.Left + sh.Width / 2 ' центр х
y0 = sh.Top + sh.Height / 2 ' центр у

Sub Макрос1()
    Dim ws As Worksheet
    Dim h As Range
    Dim nREnd As Integer
    Dim sh As Shape
    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
'==--==
        Dim Pnt As String
        Pnt = koordTi2(sh, ws)
        y = ws.Range(Pnt).Row
        x = ws.Range(Pnt).Column

'==--==
        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
'==--==
                    For R = y - rr To y + rr
                        For c = x - rr To x + rr
                         
                            ri = Abs(R - y)
                            ci = Abs(c - x)
                    
                            'Сумма квадратов разниц координат должна быть меньше квадрата радиуса _
                             По принципу вхождения точки в круг
                            If ri * ri + ci * ci <= rr * rr Then
                                If R > 6 And R < 33 And c > 9 And c < 40 Then ' границы поля
                                    'красим
                                    ws.Cells(R, c).Interior.Color = zv
                                End If
                            End If
                        Next c
                    Next R
'==--==
                End With
                Exit For
            End If
        Next i
    Next
End Sub

Function koordTi2(sh_ As Shape, ws_ As Worksheet) As String
    Dim U As Range

    With sh_
        'Это координаты центра фигуры:
        x0 = .Left + .Width / 2 ' центр по х
        y0 = .Top + .Height / 2 ' центр по у
        
        Set fig = .TopLeftCell
    End With
        
    nR = fig.Row
    nC = fig.Column
    
    i = 0
    j = nR
    For i = nC To 39
        With ws_.Cells(j, i)
            '.Select
            x1 = .Left + .Width / 2 ' центр по х
            If x1 > x0 Then
                i = i - 1
                Exit For
            End If
        End With
    Next i
    
    For j = nR To 32
        With ws_.Cells(j, i)
            '.Select
            y1 = .Top + .Height / 2 ' центр по у
            If y1 > y0 Then
                j = j - 1
                Exit For
            End If
        End With
    Next j

    'ws_.Cells(j, i).Select
    MsgBox "строка = " & j & Chr(10) & _
           "колонка = " & i, vbInformation + vbOKOnly, ""
    
    koordTi2 = ws_.Cells(j, i).Address
End Function