Moving multiple images to another worksheet using VBA - new location - excel

Question

I am creating a new sheet with the goal of reorganizing the information on another sheet. I have been able to move all other information to the other sheet in the format needed, but I can not move images/pictures of the parts.
I have tried using the code shown below, but referencing the cell the images are in, but it does not copy. I did a little research and looked at if there was a simple way to move images just by copy-pasting cells through VBA and it does not seem to work. I also look at trying to rename all the shapes, but to no success.
'find the last row of values
Worksheets("Eyelets").Activate
LastRow = Cells.Find("*", SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row + 3
Worksheets("Plot").Activate
'1st column of values
For i = 2 To LastRow Step 4
Count = Count + 1
x = i + Count
'Store all variables in the row
RDPNHold = Worksheets("Eyelets").Range("A1").Offset(i - 1, 0)
FDPNHold = Worksheets("Eyelets").Range("A1").Offset(i - 1, 1)
WRHold = Worksheets("Eyelets").Range("A1").Offset(i - 1, 4)
MatHold = Worksheets("Eyelets").Range("A1").Offset(i - 1, 9)
DiamHold = Worksheets("Eyelets").Range("A1").Offset(i - 1, 5).Value
'Move All Part Numbers to next sheet.
Worksheets("Plot").Range("A1").Offset(x - 2, 0) = RDPNText & RDPNHold
Worksheets("Plot").Range("A1").Offset(x - 1, 0) = FDPNText & FDPNHold
Worksheets("Plot").Range("A1").Offset(x, 0) = WRText & WRHold
Worksheets("Plot").Range("A1").Offset(x + 1, 0) = MatText & MatHold & DiamText & DiamHold
'Bold Specific parts of the cells
Worksheets("Plot").Range("A1").Offset(x - 2, 0).Characters(Len(lngIDStart), 3).Font.Bold = True
Worksheets("Plot").Range("A1").Offset(x - 1, 0).Characters(Len(lngIDStart), 3).Font.Bold = True
Worksheets("Plot").Range("A1").Offset(x, 0).Characters(Len(lngIDStart), 3).Font.Bold = True
Worksheets("Plot").Range("A1").Offset(x + 1, 0).Characters(Len(lngIDStart), 4).Font.Bold = True
Worksheets("Plot").Range("A1").Offset(x + 1, 0).Characters(Len(lngIDStart) + 13, 5).Font.Bold = True
Next i
Information not formateed This image shows how the information is already organized (I changed values due to work-related information)
Formatted Information This image shows how I am trying to format the information, and as shown the blank space for the images.
Any ideas or suggestions are greatly appreciated!

Answer 1

Here's a starting point:
Sub Tester()
Dim shtSource As Worksheet, shtDest As Worksheet
'....
Set shtSource = Worksheets("Eyelets")
Set shtDest = Worksheets("Plots")
'....
If CopyPicFromCell(shtSource.Range("A1").Offset(i - 1, 2)) Then
'copied the picture, so paste to shtDest
shtDest.Paste
With shtDest.Shapes(shtDest.Shapes.Count)
.Top = shtDest.Range("A1").Offset(0, 1).Top
.Left = shtDest.Range("A1").Offset(0, 1).Left
End With
End If
End Sub
'see if there's a shape to be copied from a given cell
' return True if one was found
Function CopyPicFromCell(c As Range)
Const MARGIN As Long = 10 '<< how far the picture can be out of place
Dim shp As Shape
For Each shp In c.Parent.Shapes
'check the TopLeftCell and the shape's position
If shp.TopLeftCell.Address = c.Address Or _
(Abs(shp.Left - c.Left) < MARGIN And Abs(shp.Top - c.Top) < MARGIN) Then
shp.Copy
CopyPicFromCell = True
Exit For '<< done checking
End If
Next shp
End Function