Private Sub Worksheet_Change(ByVal Target As Range)
      If Not Intersect(Target, Range("A1")) Is Nothing Then
         Application.CutCopyMode = False
                 Application.EnableEvents = False
        Application.ScreenUpdating = False
        If ActiveSheet.Pictures.Count > 0 Then Shapes("PopapTab").Delete

'ищем границы диапазона для определенной фамилии в А1
Dim i As Long
Dim j As Long
Dim FoundFIO As Range
  Set FoundFIO = Sheets("Нормы").Columns("B:C").Find(Target, , xlValues, xlWhole)
    If Not FoundFIO Is Nothing Then
      j = FoundFIO.Row
      i = j
      Do
        i = i - 1
      Loop While Sheets("Нормы").Cells(i, "A").Borders(xlEdgeTop).Weight <> xlMedium
    Else
       MsgBox "На листе 'Нормы' нет фамилии: " & Target
    End If
    
    Sheets("Нормы").Range("A" & i & ":C" & j).Copy
    
    Sheets(Target.Parent.Name).Select
    ActiveSheet.Pictures.Paste(Link:=True).Select
    Application.CutCopyMode = False
    Selection.Name = "PopapTab"
    Top = Target.Top - Selection.Height
    If Top < 0 Then Top = Target.Top + Target.Height
    Selection.Top = Top
    Selection.Left = Target.Left + Target.Width / 2
    With Selection.ShapeRange.Fill
        .Visible = msoTrue
  '      .ForeColor.ObjectThemeColor = msoThemeColorAccent1
        .ForeColor.TintAndShade = 0
'        .ForeColor.Brightness = 0.400000006
        .Transparency = 0
        .Solid
    End With
    With Selection.ShapeRange.Shadow
'        .Type = msoShadow21
        .Visible = msoTrue
'        .Style = msoShadowStyleOuterShadow
'        .Blur = 4
        .OffsetX = 4.9497474683
        .OffsetY = 4.9497474683
'        .RotateWithShape = msoFalse
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0.599999994
'        .Size = 100
    End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True
'     Target.Select
     Cancel = True
    Else
        On Error Resume Next
        ActiveSheet.Shapes("PopapTab").Delete
    End If
End Sub

With Selection.ShapeRange.Shadow