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.
--
Regards,
Tom Ogilvy
"Get a file name inside a macro"
<(E-Mail Removed)> wrote in message
news:B1D9C7A1-BBFA-495C-A435-(E-Mail Removed)...
> 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
|
Similar Threads
