Copy Pictures Sheet to Sheet
Let's say you have two worksheets: (1) The first is a standard quote worksheet which would be sent to a customer. (2) The second is an assortment of product pictures, each picture named for the product it represents.
As an example, let's say a company sells 25 products. The second worksheet would have 25 pictures. When a quote is prepared, the user would select a product number from an Excel form. This product number would then be used to look up the picture in the "pictures" worksheet and copy it to the quote worksheet so that the customer sees a picture of the product.
For example, you might have a picture named "6710B" on the pictures worksheet. (You name the picture by entering the name in the same place you would enter a Range Name). This is also the product number that the customer orders. The following two examples show how to locate the picture by name in the pictures worksheet and copy it to the customer quote worksheet.
The first example uses the SELECT technique, which is a shorter method. The second method (for Excel purists) does not do any selection (except at the very end to deactivate the selected picture), and relies on object methods exclusively that don't use the SELECT method.
Program Code
Option Explicit
Public Sub CopyASpecificPicture1()
' ***********************************************************
' How To Copy Pictures From Sheet to Sheet
' Using the SELECT method
' ***********************************************************
Dim ProductPic As Shape
Dim wkbPricingWorkbook As Workbook
Dim wksProductQuote As Worksheet
Dim wksProductPictures As Worksheet
Set wkbPricingWorkbook = ThisWorkbook
Set wksProductQuote = wkbPricingWorkbook.Sheets("6710BQuote")
Set wksProductPictures = wkbPricingWorkbook.Sheets("Pictures")
' *******************************************************
' Locate The Selected Product Picture and Place It
' At A Specific Location on the Quote Sheet
' *******************************************************
wksProductPictures.Activate
For Each ProductPic In wksProductPictures.Shapes
If ProductPic.Name = "6710B" Then
ProductPic.Select
Selection.Copy
wksProductQuote.Activate
wksProductQuote.Paste
Selection.Top = 11.25
Selection.Left = 405.75
wksProductQuote.Cells(1, 1).Select
wksProductPictures.Activate
wksProductPictures.Cells(1, 1).Select
wksProductQuote.Activate
Exit For
End If
Next ProductPic
End Sub
Public Sub CopyASpecificPicture2()
' ***********************************************************
' How To Copy Pictures From Sheet to Sheet
' Using Object Methods Excluding The SELECT method
' And Place It At A Specific Location on the Quote Sheet
' ***********************************************************
Dim ProductPic As Shape
Dim ProductPicCopy As Shape
Dim wkbPricingWorkbook As Workbook
Dim wksProductQuote As Worksheet
Dim wksProductPictures As Worksheet
Dim FoundThePic As Boolean
Set wkbPricingWorkbook = ThisWorkbook
Set wksProductQuote = wkbPricingWorkbook.Sheets("6710BQuote")
Set wksProductPictures = wkbPricingWorkbook.Sheets("Pictures")
' *******************************************************
' Locate The Selected Product Picture From The Pictures
' Sheet
' *******************************************************
FoundThePic = False
wksProductQuote.Activate
For Each ProductPic In wksProductPictures.Shapes
If ProductPic.Name = "6710B" Then
ProductPic.Copy
wksProductQuote.Paste
For Each ProductPicCopy In wksProductQuote.Shapes
If ProductPic.Name = ProductPicCopy.Name Then
ProductPicCopy.Top = 11.25
ProductPicCopy.Left = 405.75
FoundThePic = True
Exit For
End If
Next ProductPicCopy
End If
If FoundThePic Then
Exit For
End If
Next ProductPic
' ********************************************************
' Clean Up Residual Selections
' ********************************************************
wksProductQuote.Cells(1, 1).Select
End Sub