Copying image between the sheets with instant resizing & adjusting - excel

Question

I have got a problem.
I would like to copy the image between the Excel sheets and have it adjusted at once to the cells.
So far I managed perfectly with adjustment on the 1 sheet
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
Which looks like this:
To the image is assigned the ID, as shown below:
Now, I want to copy this image into another 2 sheets, which can be done by this solution:
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
Everything would be fine, but I am receiving an image of the same size.
It has to be fitted with the cells. Technically it's feasible by using the code above and changing the shape ID into the new one copied. Unfortunately, I can't do this, since I would like to use one image and make it copied & resized instantly in all sheets.
What should I do to receive this goal?

Answer 1

Sheets("Sign Off Sheet").Shapes("Picture 13").Copy
Sheets("BoQ Civils").Range("C43").PasteSpecial
Work with Objects. It will be easier to handle them
Try this
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
Edit: If the shape name is getting renamed after copying it across then use Sheets("BoQ Civils").Shapes.Count to work with the shape as #Plutian suggested in the chat
Set shpB = Sheets("BoQ Civils").Shapes(Sheets("BoQ Civils").Shapes.Count)

Answer 2

You can create a resize function
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

Answer 3

You could use the .Scaleheight method to scale by the height of the target cell. This will keep the aspect ratio of the picture while resizing with the height of the cell. By the looks of your picture, the target cell might be wider or narrower than you want your picture to be.
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