Excel VBA to change the size of all shapes in workbook

[Roxanne8912]

Hello,

Does anyone have VBA code whichselects all shapes in a workbook and then sizes them the same height and width(1 in X 1in). The shapes are embeddedDocuments and Packager Shell Object


Below is code where I am splitting atable into multiple sheets. The splitworks great with one exception. Theshapes do not copy over as the same size and they will stack in the first rowof the new sheet. I have solved for the stacking issue but cannot seem tosize the shapes.

Any help would be appreciated.





'Split table

Set asheet= ActiveSheet
lastrow =asheet.Range("A" & Rows.Count).End(xlUp).Row
myarray =uniqueValues(asheet.Range("A2:A" & lastrow))
Dim Sh AsShape
For i =LBound(myarray) To UBound(myarray)
Sheets.Add.Name = myarray(i)
asheet.Range("A1:AE" & lastrow).AutoFilter Field:=1,Criteria1:=myarray(i)
asheet.Range("A1:AE" &lastrow).SpecialCells(xlCellTypeVisible).Copy _
Sheets(myarray(i)).Range("A1:AE1")
asheet.Range("A1:AE" & lastrow).AutoFilter

' Remove shapes from header row (Previous rowcarries over as a thin line stored in header row)

Dim ShpAs Shape
Dim rAs Range
Set r =Range("A1:AE1")

ForEach Shp In ActiveSheet.Shapes
If Not Intersect(Range(Shp.TopLeftCell, Shp.BottomRightCell), r) IsNothing Then _
Shp.Delete
Next Shp

' Resizesshapes
DimShp2 As Shape
Dim r2As Range
Setr2 = Range("A1:AE" & lastrow)

ForEach Shp2 In ActiveSheet.Shapes
If Not Intersect(Range(Shp2.TopLeftCell, Shp2.BottomRightCell), r) IsNothing Then _
Shp2.Width = 35

Shp2.Height = 35

Next Shp2
Next i

 

[tonyyy]

Roxanne8912,

You might consider a couple subtle changes...

Before:

' Resizes shapes
DimShp2 As Shape
Dim r2 As Range
Set r2 = Range("A1:AE" & lastrow)

For Each Shp2 In ActiveSheet.Shapes
If Not Intersect(Range(Shp2.TopLeftCell, Shp2.BottomRightCell), r) Is Nothing Then _
    Shp2.Width = 35
    Shp2.Height = 35
Next Shp2

After:

' Resizes shapes
DimShp2 As Shape
Dim r2 As Range
Set r2 = Range("A1:AE" & lastrow)

For Each Shp2 In ActiveSheet.Shapes
If Not Intersect(Range(Shp2.TopLeftCell, Shp2.BottomRightCell), r2) Is Nothing Then
    Shp2.Width = 35
    Shp2.Height = 35
End If
Next Shp2

Changed the range reference from "r" to "r2". Removed the underscore in the If/Then statement.

Cheers,

tonyyy

 

[Roxanne8912]

Thank you for the response. I cannot believe I missed the r2. I also removed the underscore and added an else if and it works now if there is only one shape in a cell. Any thoughts for two or three shapes in a cell? Currently, the second shape stays as a very small rectangle.

Below is the updated code.

' Resizes shapes
Dim Shp2 As Shape
Dim r2 As Range
Set r2 = Range("A1:AE" & lastrow)

For Each Shp2 In ActiveSheet.Shapes
If Not Intersect(Range(Shp2.TopLeftCell, Shp2.BottomRightCell), r2) Is Nothing Then
Shp2.Width = 1
Shp2.Height = 30
Else
End If
Next Shp2

 

[tonyyy]

In my simple testing, it seems embedded documents don't behave the same as Excel shapes... so indeed the result could be a "very small rectangle." Do you plan to position the shapes as well as resize them? If so, you might consider the following...

' Resizes shapes
Dim Shp2 As Shape
Dim r2 As Range
Dim lft As Long
Set r2 = Range("A1:AE" & lastrow)
lft = 0

For Each Shp2 In ActiveSheet.Shapes
    If Not Intersect(Range(Shp2.TopLeftCell, Shp2.BottomRightCell), r2) Is Nothing Then
        With Shp2
            Shp2.Left = lft
            Shp2.Top = Range("A" & lastrow).Top
            Shp2.Width = 30
            Shp2.Height = 30
        End With
    End If
    lft = lft + 30
Next Shp2

This will size each shape to a 30x30 square and place them left to right along the last row.

 

[Roxanne8912]

Hello. Thank you for the feedback. The shapes should stay in the appropriate row. Each row refers to a different subject matter. Each subject matter might have 0 - 3 embedded documents.

Before the worksheet split (Single cell):
<missing image removed>

After my code (single cell). I am trying to solve for the small rectangle on the left.
<missing image removed>