Цитата
поставить подсказку в лист Алмакаев
'ActiveSheet.Pictures.Paste(Link:=True).Select не работает с умной таблицей
Преобразовал таблицу в диапазон
[vba]Код
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
[/vba]