Loop through shapes with VBA

EmileVBA

New Member
Joined
Aug 25, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hi, I have a file with 2 macros in it.

The first macro loops through each shape in range D1:D100 and selects all the shapes (in this case they are rectangles).
The second macro does the movement by storing the top & left locations, and the height & width of the previous shape in variables (dTop, dLeft, dHeight, dWidth). The next shape in the loop is then moved by setting the top and left properties based on those variables.

The benefit of the second macro is that it changes the order of the shapes, based on the order that I select the shapes manually with CTRL + click. But I don't want to make the selections manually, but automatically by VBA.

So if the shapes are selected by the first macro, it will order them by number, i.e. Rectangle 1, Rectangle 2, Rectangle 3, Rectangle 4 and so on. If I change the order of the shapes, i.e. Rectangle 2, Rectangle 4, Rectangle 3 and then Rectangle 1 (and to be complete: the shapes can be on top of each other, therefore I want them to align vertically), and I use the first macro to select the shapes automatically by VBA, I would like to have the second macro to align them from top to bottom as I have positioned them (by dragging) in column D. Resulting in the order Rectangle 2, Rectangle 4, Rectangle 3 and then Rectangle 1. But the result after running both macros is, that the order is restored to Rectangle 1, Rectangle 2, Rectangle 3, Rectangle 4.

My question is: how to adjust the selection in the first macro, so that the selection of the shapes is done by position of the shapes in column D, instead of the number of the shapes?

These are the macro's I use:
First macro:
VBA Code:
Sub SelectShapes()
Dim shp As Shape
Dim r As Range

Set r = Range("D1:D100")

For Each shp In ActiveSheet.Shapes
    If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), r) Is Nothing Then _
        shp.Select Replace:=False
Next shp
End Sub

Second macro:
VBA Code:
Sub AutoSpaceShapes()
'Automatically space and align shapes vertically.

Dim shp As Shape
Dim lCnt As Long
Dim dTop As Double
Dim dLeft As Double
Dim dHeight As Double
Const dSPACE As Double = 8 'Set space between shapes in points

  'Check if shapes are selected
  If TypeName(Selection) = "Range" Then
    MsgBox "Please select shapes before running the macro."
    Exit Sub
  End If
  
  'Set variables
  lCnt = 1
  
  'Loop through selected shapes (charts, slicers, timelines, etc.)
  For Each shp In Selection.ShapeRange
    With shp
      'If not first shape then move it below previous shape and align left.
      If lCnt > 1 Then
        .Top = dTop + dHeight + dSPACE
        .Left = dLeft
      End If
      
      'Store properties of shape for use in moving next shape in the collection.
      dTop = .Top
      dLeft = .Left
      dHeight = .Height
    End With
    
    'Add to shape counter
    lCnt = lCnt + 1
    
  Next shp

End Sub

Hopefully this is clear, otherwise let me know. I hope there will be a solution to my challenge. Looking forward to your reaction, thank you!
 

Some videos you may like

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,624
Welcome to MrExcel forums.

Here's one way:
VBA Code:
Sub SelectShapes2()

    Dim shp As Shape
    Dim r As Range
    Dim cell As Range
    Dim selectedShapes As String
    
    Set r = Range("D1:D100")
    selectedShapes = "|"
    For Each cell In r
        For Each shp In ActiveSheet.Shapes
            If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), cell) Is Nothing Then
                If InStr(selectedShapes & "|", "|" & shp.Name & "|") = 0 Then
                    selectedShapes = selectedShapes & shp.Name & "|"
                    shp.Select Replace:=False
                End If
            End If
        Next shp
    Next
    
End Sub
 

EmileVBA

New Member
Joined
Aug 25, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hi John, thank you! The solution you have provided works indeed! Many thanks for providing this solution, makes me very happy. :)
 

Watch MrExcel Video

Forum statistics

Threads
1,123,426
Messages
5,601,595
Members
414,462
Latest member
StageRiis

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top