Opgelost macro voor range selecteren kopiëren als afbeelding en verkleind plakken

[dr.Danz]

Zou iemand weten hoe ik een macro voor range selecteren kopieren als afbeelding en verkleind plakken kan maken ik kan het wel de eerste keer met afbeelding 1 maar dan verspringt hij als je het de 2de keer doet naar afbeelding 2 en verkleint hij nogmaals afbeelding 1 en zet de 2de normaal neer.

Mijn simpele macro is :
Sub SELECT1()
Range("E2:N32").Select
Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
Sheets("A3BLAD").Select
ActiveSheet.Paste
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
End Sub
Als ik dan:
Selection.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft

toevoeg na ActiveSheet.Shapes.Range(Array("Picture 1")).Select verkleint hij dus weer picture 1 omdat die niet variabel is.
Ik zou dus graag willen dat afbeelding 2 ook wordt verkleind en een derde en vierde ook.

Iemand misschien een idee?

 

[AHulpje]

Zo:

Sub SELECT2()
    Range("E2:N32").CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    Sheets("A3BLAD").Select
    ActiveSheet.Paste
    Selection.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
    MsgBox "Nieuwe shape: " & Selection.Name
End Sub

 

[dr.Danz]

bedankt

 

[snb]

Na het plakken is de geplakte afbeelding geselecteerd. Borduur daar dan op voort.

Sub M_snb()
 ActiveSheet.Range("A1:F9").CopyPicture
 
 With Sheet2
     .Paste .Cells(12, 10)
  End With
  Selection.ShapeRange.ScaleHeight 0.5, 0
End Sub

Na het plakken is het indexnummer van de afbeelding gelijk aan het aantal afbeeldingen in het werkblad.
Dus het kan ook zó:

Sub M_snb()
 ActiveSheet.Range("A1:F9").CopyPicture
 
 With Sheet2
     .Paste .Cells(12, 10)
     .Shapes(.Shapes.Count).ScaleHeight 1.9, 0
  End With
End Sub