Loop through shapes with VBA

[EmileVBA]

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:

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:

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!

 

[John_w]

Welcome to MrExcel forums.

Here's one way:

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]

Hi John, thank you! The solution you have provided works indeed! Many thanks for providing this solution, makes me very happy.