Copy several photos in a macro

[Get a file name inside a macro]

Hi everyone:

I have a worksheet with 4 pictures on it, I need to copy this pictures in
the same worsheet but in a diferent location, I need to make the picture name
generic.
I want to make the following macro to work with any picture name:

Sub FotoCopy()
'
' FotoCopy Macro
' Macro recorded 3/16/2007 by ER
'
' Keyboard Shortcut: Ctrl+d
'
ActiveSheet.Shapes("Picture 339").Select
Selection.Copy
ActiveSheet.Shapes("Picture 253").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 225.75
Selection.ShapeRange.IncrementTop -12#
ActiveSheet.Shapes("Picture 335").Select
Selection.Copy
ActiveSheet.Shapes("Picture 261").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 226.5
Selection.ShapeRange.IncrementTop -12#
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 10
ActiveWindow.ScrollRow = 11
ActiveSheet.Shapes("Picture 336").Select
Selection.Copy
ActiveSheet.Shapes("Picture 271").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 226.5
Selection.ShapeRange.IncrementTop -12#
ActiveWindow.ScrollRow = 12
ActiveWindow.ScrollRow = 13
ActiveWindow.ScrollRow = 14
ActiveWindow.ScrollRow = 15
ActiveWindow.ScrollRow = 16
ActiveWindow.ScrollRow = 18
ActiveWindow.ScrollRow = 19
ActiveWindow.ScrollRow = 20
ActiveSheet.Shapes("Picture 337").Select
Selection.Copy
ActiveSheet.Shapes("Picture 281").Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 226.5
Selection.ShapeRange.IncrementTop -13.5
End Sub

Thank you for you help

 

[Joel]

Learn Macro put a lot of code that is unecessary. this code is much simplier
than original code. You may want to adjust these two lines

where 1st picture is located, change as required
ScrollCount = 4

Spacing between picture is 10, change as required
ScrollCount = ScrollCount + 10 the


Sub FotoCopy()
'
' FotoCopy Macro
' Macro recorded 3/16/2007 by ER
'
' Keyboard Shortcut: Ctrl+d
'
ScrollCount = 4
For Each MyPicture In ActiveSheet.Shapes
ActiveWindow.ScrollRow = ScrollCount
ActiveSheet.Shapes(MyPicture.Name).Select
Selection.Copy
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft 225.75
Selection.ShapeRange.IncrementTop -12#
ScrollCount = ScrollCount + 10
Next MyPicture
End Sub

 

[Tom Ogilvy]

State the cell under the upper left corner of each picture and where you
want each picture copied to in terms of what the cell would be under the
upper left corner.

Sub CopyPictures()
Dim vCurrent As Variant, vFuture As Variant
Dim i As Long, pic As Picture
vCurrent = Array("A1", "A11", "A21", "A31")
vFuture = Array("M11", "M1", "M31", "M21")
For i = LBound(vCurrent) To UBound(vCurrent)
For Each pic In ActiveSheet.Pictures
If pic.TopLeftCell.Address(0, 0) = vCurrent(i) Then
pic.Copy
Range(vFuture(i)).Select
ActiveSheet.Paste
Exit For
End If
Next pic
Next i
End Sub

You have to specify something about the pictures to use to identify which
picture to copy to where. Hopefully specifying the cell underneath the
upper left corner is consistent with what you are doing.