Копирование изображения между листами с мгновенным изменением размера и настройкой

Question

У меня проблема. Я хотел бы скопировать изображение между листами Excel и настроить его сразу по ячейкам.

До сих пор я отлично справился с настройкой на 1 листе

  Sub signature()
  Dim myImage As Shape
  Dim imageWidth As Double
  Dim imageHeight As Double

  Set myImage = ActiveSheet.Shapes("Picture 13")
  imageWidth = 170
  imageHeight = 65

  myImage.LockAspectRatio = msoFalse
  myImage.Width = imageWidth
  myImage.Height = imageHeight

  'x:
  myImage.Left = myImage.Left + 650

  'y:
  myImage.Top = myImage.Top - 70

  End Sub

, которая выглядит как это:

Для изображения назначен идентификатор, как показано ниже:

Теперь я хочу скопировать это изображение на еще 2 листа, что можно сделать с помощью этого решения:

 Sub signature_copy()
   Sheets("Sign Off Sheet").Shapes("Picture 13").Copy
   Sheets("BoQ Civils").Range("C43").PasteSpecial
   Sheets("BoQ Cabling").Range("C37").PasteSpecial

 End Sub

Все будет хорошо, но я получаю изображение того же размер.

Должен быть снабжен ячейками. Технически это возможно, используя приведенный выше код и меняя идентификатор формы на новый скопированный. К сожалению, я не могу этого сделать, так как я хотел бы использовать одно изображение и сделать его копируемым и мгновенно изменяющим размер на всех листах.

Что я должен сделать, чтобы получить эту цель?

Answer 1

Листы ("Sign Off Sheet"). Фигуры ("Рисунок 13"). Копия

Листы ("Граждане BoQ"). Диапазон ("C43"). PasteSpecial

Работа с объектами. Обрабатывать их будет проще

Попробуйте это

Option Explicit

Sub Sample()
    Dim shpA As Shape, shpB As Shape
    Dim rng As Range

    Set shpA = Sheets("Sign Off Sheet").Shapes("Picture 13")
    shpA.Copy

    Set rng = Sheets("BoQ Civils").Range("C43")
    Sheets("BoQ Civils").Paste Destination:=rng

    Set shpB = Sheets("BoQ Civils").Shapes("Picture 13")

    With shpB
        .Top = rng.Top
        .Left = rng.Left
        .Width = rng.Width
        .Height = rng.Height
    End With
End Sub

Редактировать : если имя фигуры переименовывается после ее копирования, используйте Sheets("BoQ Civils").Shapes.Count для работы с формой, предложенной @Plutian в чате

Set shpB = Sheets("BoQ Civils").Shapes(Sheets("BoQ Civils").Shapes.Count)

Answer 2

Вы можете использовать метод .Scaleheight для масштабирования по высоте целевой ячейки. Это сохранит соотношение сторон изображения при изменении размера с высотой ячейки. Судя по изображению, целевая ячейка может быть шире или уже, чем вы хотите.

Sub signature_copy()
Dim sh As Shape

    Sheets("Sign Off Sheet").Shapes("Picture 13").copy

    Sheets("BoQ Civils").Range("C43").PasteSpecial

    Set sh = Sheets("BoQ Civils").Shapes(Sheets("BoQ Civils").Shapes.Count)

    With sh
        .ScaleHeight Factor:=(.TopLeftCell.Height / .Height), RelativeToOriginalSize:=msoTrue
    End With

End Sub

Answer 3

Вы можете создать функцию изменения размера

Sub Example2()
SizeToRange ActiveSheet.Pictures("Picture 13"), Range("C43:D43")
End Sub

Function SizeToRange(s, Target As Range)
s.Left = Target.Left
s.Top = Target.Top
s.Width = Target.Width
s.Height = Target.Height
End Function