Sub Макрос3()
Application.ScreenUpdating = False
Dim sh As Worksheet, cell As Range
Set sh = ActiveSheet
Sheets("Печать").Select
ActiveSheet.Shapes.Range(Array("Group 1")).Select
Selection.Copy
sh.Select
Set cell = sh.Range("A:L").Find("Генеральный директор*")
If Not cell Is Nothing Then
sh.Cells(cell.Row - 1, cell.Column + 3).Select
ActiveSheet.Paste
End If
Application.ScreenUpdating = True
End Sub
Sub пп()
'путь к папке с картинками
Const sPicsPath As String = "C:\Users\.....\"
Dim sPicName As String, sPFName As String, sSpName As String
Dim oShp As Shape
Dim zoom As Double
Application.ScreenUpdating = False
Dim sh As Worksheet, cell As Range
Set sh = ActiveSheet
Set cell = sh.Range("A:L").Find("Генеральный директор*")
sPicName = "1.png" 'ИМЯ ВАШЕЙ ПОДПИСИ И ПЕЧАТИ
'если имя картинки не задано
If sPicName = "" Then
Exit Sub
End If
'проверяем наличие картинки в папке
sPFName = sPicsPath & sPicName
If Dir(sPFName, 16) = "" Then
Exit Sub
End If
'в эту ячейку вставляем картинку
If Not cell Is Nothing Then
With sh.Cells(cell.Row - 1, cell.Column + 3)
On Error Resume Next
'задаем картинке уникальный адрес,
'привязанный к адресу ячейки
sSpName = "_" & .Address(0, 0) & "_autopaste"
'если картинка уже есть - удаляем её
Set oShp = ActiveSheet.Shapes(sSpName)
If Not oShp Is Nothing Then
oShp.Delete
End If
'вставляем выбранную картинку
Set oShp = ActiveSheet.Shapes.AddPicture(sPFName, False, True, .Left + 1, .Top + 1, -1, -1)
'определяем размеры картинки в зависимости от размера ячейки
zoom = Application.Min(.Width / oShp.Width, .Height / oShp.Height)
'переименовываем вставленную картинку(чтобы потом можно было заменить)
oShp.Name = sSpName
End With
End If
Application.ScreenUpdating = True
End Sub
Ибрагим Белхороев, вы серьезно? откуда ему брать печать? если она сделана на доп.листе который называется ПЕЧАТЬ и которого у Вас нет... выше дал вам ссылку и по ней сделал вам макрос - там вам нужно заменить путь откуда брать печать и название файла.
Ибрагим, ну Вы хоть маленько начинайте вникать в макросы, а не просто тупо их копируйте, не прилагая никаких усилий для того, чтобы понять производимые в макросе действия...
Цитата
Ибрагим Белхороев написал: не знаете почему при другой печати этот код ссылается на ошибку?