VBA Moving Objects

[giuliano95]

Hello,

I am new in the forum,

I am having a problem with VBA,

I have an excel file, with an N number of shapes which are all the same and increase with the time, lets say there is one extra shape a week,

All the shape are aligned in 4 columns from the newest to the oldest ( 1 is the newest and 8 the oldest) in reality they are much more than 8

1 2 3 4
5 6 7 8

I would need a macro that every time I add a new one switch the shapes so I have a blank space to paste my new one instead of the 1 shape ie

1 2 3 4
5 6 7 8

has anybody ever done it or can help?
I am trying on internet but I am not managing to make it work

Thank you in advance

 

[Yongle]

Welcome to the forum
- a few questions
- not all shapes behave the same!

1 Is this a clean start ?
- or are you expecting the code to work with existing shapes?

2 Are the shapes simple rectangles as illustrated in your post ?
( non-geometric shapes may require different code )

3 Is shape text linked to a cell ?
( it may be possible to automate this )

4 Are macros assigned to the shapes ?

5 What is your naming convention ?

6 Is the trigger to create a new shape
- manual (ie user decides) ?
- could it be determined by a change in a value in a worksheet?

7 It would be simplest if each new shape is numbered sequentally - is there any reason why this is not possible?

 

[giuliano95]

Hi Yongle,
Thank you a lot,

So,

1- it's not a clean start but if it's impossible with old shapes still better than nothing
2- the shapes are rectangle or very similar to them, anyway basic shapes from excel (if you know what they are they are tombstones)
3- the shapes aren't linked to anything but contain a little formatted text and a little picture in it
4- no macros
5- no particular name convention.. we can decide it all
6- the trigger is completely manual, likely it's a copy paste from another file/sheet
7- the shapes can be numbered for sure if it's not visible to a simple reader

Thank you a lot for the help!

 

[mikerickson]

It sounds like you already have shapes in an N X 4 grid.
Are all the shapes similar in size?

 

[giuliano95]

Hi thanks a lot for the answers, yes the shape are identical in everything besides the information of the text and the pic

 

[giuliano95]

Hi thanks a lot for the answers, yes the shape are identical in everything besides the information of the text and the pic,

Rather it's a 4 grid but the number of rows is let's say unlimited since from time to time there is a new shape

 

[Yongle]

the shape .... contains a little formatted text and a little picture in it

Q how are the picture and shape linked together? are they grouped?

no particular name convention
shapes can be numbered for sure if it's not visible to a simple reader

- it is best to tidy up the historic names for ongoing consistency
Q What do you want to call your shapes? - I need the name string

Renaming existing shapes

I will post some VBA later to allow you to manually select each shape in sequence (starting with youngest)
- the VBA will auto-rename each shape - using your name string followed by the next number in sequence

 

[giuliano95]

Yes they are grouped together, the name is not important they can be called just with numbers to make it easier

 

[giuliano95]

The hard thing is that by pressing the macro it has to switch them all of a position, if it's the case create a new row and in order from thr newest to the oldest so top left is the newest bottom right the oldest

 

[mikerickson]

If you have shapes on a sheet, the following code will put it in a N row, 4 column grid.
(Adjust the HGap and VGap constants to your taste.)

Adjust the LeaveBlank variable will leave blank places.
LeaveBlank = 0 will put the first shape in the top left corner of the grid, row 1 column 1
LeaveBlank = 1 will put the top left existing shape in row 1 column 2

You can either run it on existing sheet with LeaveBlank = 1 and put your new shape in the space left in row 1 column 1.
Or you can put your new shape on the existing sheet with the New shape as the top left shape on the sheet and then run the program with LeaveBlank = 0.

This will ignore controls on the sheet from the Forms menu, to allow you to run it by a button.

Sub test()
    Dim oneShape As Shape
    Dim minTop As Single, minLeft As Single
    Dim maxHeight As Single, maxWidth As Single
    Dim hIndex As Long, vIndex As Long
    Dim LeaveBlank As Long
    Dim currShapes As Collection
    Dim i As Long
    Dim flag As Boolean

    Const HGap As Single = 30: Rem adjust
    Const VGap As Single = 10: Rem adjust
    LeaveBlank = 1: Rem adjust
    
    minTop = 9e+15: minLeft = 9e+15
    For Each oneShape In ActiveSheet.Shapes
        If oneShape.Type <> msoFormControl Then
            With oneShape
                If .Top < minTop Then minTop = .Top
                If .Left < minLeft Then minLeft = .Left
                If maxHeight < .Height Then maxHeight = .Height
                If maxWidth < .Width Then maxWidth = .Width
            End With
        End If
    Next oneShape
    
    For Each oneShape In ActiveSheet.Shapes
        If oneShape.Type <> msoFormControl Then
            With oneShape
                .Top = minTop + Int((.Top - minTop) / maxHeight) * (maxHeight + VGap)
                .Left = minLeft + Int((.Left - minLeft) / maxWidth) * (maxWidth + HGap)
            End With
        End If
    Next oneShape
    Application.ScreenUpdating = True
    
    Set currShapes = New Collection
    For Each oneShape In ActiveSheet.Shapes
        If oneShape.Type <> msoFormControl Then
            flag = False
            For i = 1 To currShapes.Count
                If oneShape.Top < currShapes(i).Top Then
                    currShapes.Add Item:=oneShape, before:=i
                    flag = True
                    Exit For
                ElseIf oneShape.Top = currShapes(i).Top Then
                    If oneShape.Left < currShapes(i).Left Then
                        currShapes.Add Item:=oneShape, before:=i
                        flag = True
                        Exit For
                    End If
                End If
            Next i
            If Not flag Then currShapes.Add Item:=oneShape
        End If
    Next oneShape
    
    hIndex = LeaveBlank:  vIndex = 0
    
    For Each oneShape In currShapes
        oneShape.Top = minTop + vIndex * (maxHeight + VGap)
        oneShape.Left = minLeft + hIndex * (maxWidth + HGap)
        hIndex = hIndex + 1
        If 3 < hIndex Then
            hIndex = 0
            vIndex = vIndex + 1
        End If
    Next oneShape
End Sub

Note that this does not know "old" or "new", it snaps existing shapes to a grid and then shift those shapes within the grid.
If the exisitign shapes are "newest in R1 C1, next newest in R1 C2, next newest in R1 C3,..." it will maintain that new>>old order in the shifted grid.