Relocation of multiple images with ID changing

Question

I would like to make a relocation (cut & paste) for quite a few images.

The Shape ID changes 1 by one, the same as the Selection. name value

The target cells also change by 1 value, as you can see.

My code looks as follows:

Private Sub ChamberImage_Click()

ActiveSheet.Shapes("Textbox_Chamber1").Cut
ActiveSheet.Range("AA70").PasteSpecial
Selection.Name = "Textbox_Chamber1"

ActiveSheet.Shapes("Textbox_Chamber2").Cut
ActiveSheet.Range("AA71").PasteSpecial
Selection.Name = "Textbox_Chamber2"

ActiveSheet.Shapes("Textbox_Chamber3").Cut
ActiveSheet.Range("AA72").PasteSpecial
Selection.Name = "Textbox_Chamber3"

ActiveSheet.Shapes("Textbox_Chamber4").Cut
ActiveSheet.Range("AA73").PasteSpecial
Selection.Name = "Textbox_Chamber4"

ActiveSheet.Shapes("Textbox_Chamber5").Cut
ActiveSheet.Range("AA74").PasteSpecial
Selection.Name = "Textbox_Chamber5"

ActiveSheet.Shapes("Textbox_Chamber6").Cut
ActiveSheet.Range("AA75").PasteSpecial
Selection.Name = "Textbox_Chamber6"

ActiveSheet.Shapes("Textbox_Chamber7").Cut
ActiveSheet.Range("AA76").PasteSpecial
Selection.Name = "Textbox_Chamber7"

ActiveSheet.Shapes("Textbox_Chamber8").Cut
ActiveSheet.Range("AA77").PasteSpecial
Selection.Name = "Textbox_Chamber8"

ActiveSheet.Shapes("Textbox_Chamber9").Cut
ActiveSheet.Range("AA78").PasteSpecial
Selection.Name = "Textbox_Chamber9"

End Sub

How can I write it much smarter? Is it some loop on it?

3

Use a loop from 1 to 9 – Tim Williams Mar 06 '20 at 16:07

score 1 · Accepted Answer · answered Mar 06 '20 at 19:17

Without the cut/paste:

Private Sub ChamberImage_Click()

    Dim i as long , shp, ws as worksheet

    set ws = activesheet

    For i = 1 to 9

        set shp = ws.Shapes("Textbox_Chamber" & i)

        with ws.Range("AA70").Offset(i - 1 , 0)
            shp.top = .Top
            shp.left = .Left
        end with

    Nexti

End Sub

Relocation of multiple images with ID changing

1 Answers1

Linked