We may store pictures in the worksheet and want to use the picture for another purpose. To do so, the picture has to be copied and pasted to the needed position by attaching to a cell. The picture needed to be resized. This page discussed a short and simple procedure to copy a picture, paste to another worksheet and resize it.
Delete the picture which is already existing with the same name by looping through all the shapes to find the shape of the same name. Us the For Each ... Next structure.
Option Explicit Option Base 1 Option Compare Text Sub CopyPasteResizePicture() Dim FrWs As String, FrPic As String, ToWs As String Dim r As Long, c As Long, rs As Long, cs As Long Application.ScreenUpdating = False '****************************************************** 'Input data '****************************************************** FrWs = "ch3 measurement" 'The name of worksheet where the master picture resides FrPic = "Picture 3-1" 'The name of the picture ToWs = "Sheet1" 'The name of worksheet where the picture is pasted and attached to a cell r = 1 'The row of the top left cell for the picture c = 1 Sub CopyPasteResizePicture() Dim FrWs As String, FrPic As String, ToWs As String Dim r As Long, c As Long, rs As Long, cs As Long Application.ScreenUpdating = False '************************************************************* 'Input data '************************************************************* FrWs = "ch3 measurement" 'The name of worksheet where the master picture resides FrPic = "Picture 3-1" 'The name of the picture ToWs = "Sheet1" 'The name of worksheet where the picture is pasted and attached to a cell r = 1 'The row of the top left cell c = 1 'The column of the top left cell rs = 2 'The number of rows, representing the height of the picture cs = 2 'The number of columns, representing the width of the picture '************************************************************* 'Delete an existing shape of the same name. '************************************************************ For Each sh In Worksheets(ToWs).Shapes If sh.Name = FrPic Then sh.Delete End If Next
Picture is copied and pasted to another worksheet using the Copy and Paste method.
'************************************************************** 'Copy and Paste 'Bear in mind that ThisWorkBook Object is used to include the case ' where the picture is stored in the worksheet of Excel Addin. '************************************************************** ThisWorkbook.Worksheets(FrWs).Pictures(FrPic).Copy ActiveWorkbook.Worksheets(ToWs).Paste
The picture is attached to a cell and sit in the range using the Left, Top, Width, and Height properties.
Teh picture is resized autmatically at the same Aspect Ratio.
In order to resize to the height and width as given, use the LockAspectRatio = msoFalse statement.
'************************************************************** 'Reposition and resize the picture '************************************************************** With Selection .ShapeRange.LockAspectRatio = msoFalse .Left = Cells(r, c).Left .Top = Cells(r, c).Top .Width = Cells(r, c).Resize(1, cs).Width .Height = Cells(r, c).Resize(rs, 1).Height End With Application.CutCopyMode = False End SubThe
Dated on: 19 November 2019