Resize and Move to Fit

[Pestomania]

Hi everyone,

I'm not sure if this is even possible but it would be awesome!!

Is there a vba code to select all pictures and textboxes *only* and rearrange, resize to make all of them fit on the Excel sheet without overlay of each other or overlay of text in column A?

 

[Pestomania]

You said you wanted to resize them and this is the line that is doing it

.Width = 100

How do you want to resize?
- are images to be treated same as textboxes etc?
Are all images named "Picture " followed by a number?
Are all TextBoxes named "TextBox" followed by a number?

Hi. I want every thing that is a "picture" to resize and fill the width of the print area. Sorry for all of the confusion.

 

[Yongle]

So are you wanting this calculation applied
PArea = PrintArea width
TBoxes = combined widths of text boxes
Each Pic width = (pArea - Tboxes) divided by number of pictures

 

[Pestomania]

So are you wanting this calculation applied
PArea = PrintArea width
TBoxes = combined widths of text boxes
Each Pic width = (pArea - Tboxes) divided by number of pictures

Yes. That sounds like what I would be looking for. The width should stop at Column T and the height should be under the last row and not past the print area.

 

[Yongle]

See if this gives you what you want
- it is only considering the width of the print area at the moment
- that may break your last row constraint

To take account of the row constraint
- add a further test at the end of the code
- test to see if the height of any of the pictures is greater than the height alowed
- height allowed = total row heights of the rows in the print area lying below the last cell containing text in column A
- if any picture is too tall, then reduce its height to the maximum allowed

Sub reArrange()
    Dim Shp As Shape, L As Double, T As Double, W As Double, cP As Long
    With ActiveSheet
        W = Range(.PageSetup.PrintArea).Width                   'total width
        With .Range("A" & Rows.Count).End(xlUp).Offset(1)
            L = .Left
            T = .Top
        End With
        For Each Shp In .Shapes
            If Shp.Type = msoPicture Then
                cP = cP + 1                                     'count pictures
            Else
                W = W - Shp.Width                               'deduct shape width
            End If
        Next Shp
        
        If W > 0 And cP > 0 Then W = (W / cP) Else W = 1000     'divide available width by number of pictures
                                                                'prevents code failing if textboxes too wide or there are zero pictures
        For Each Shp In .Shapes
            With Shp
                .Top = T
                .Left = L
                If .Type = msoPicture Then .Width = W           'resize pictures only
                L = L + Shp.Width
            End With
        Next Shp
    End With
End Sub

 

[Pestomania]

See if this gives you what you want
- it is only considering the width of the print area at the moment
- that may break your last row constraint

To take account of the row constraint
- add a further test at the end of the code
- test to see if the height of any of the pictures is greater than the height alowed
- height allowed = total row heights of the rows in the print area lying below the last cell containing text in column A
- if any picture is too tall, then reduce its height to the maximum allowed

Sub reArrange()
    Dim Shp As Shape, L As Double, T As Double, W As Double, cP As Long
    With ActiveSheet
        W = Range(.PageSetup.PrintArea).Width                   'total width
        With .Range("A" & Rows.Count).End(xlUp).Offset(1)
            L = .Left
            T = .Top
        End With
        For Each Shp In .Shapes
            If Shp.Type = msoPicture Then
                cP = cP + 1                                     'count pictures
            Else
                W = W - Shp.Width                               'deduct shape width
            End If
        Next Shp
        
        If W > 0 And cP > 0 Then W = (W / cP) Else W = 1000     'divide available width by number of pictures
                                                                'prevents code failing if textboxes too wide or there are zero pictures
        For Each Shp In .Shapes
            With Shp
                .Top = T
                .Left = L
                If .Type = msoPicture Then .Width = W           'resize pictures only
                L = L + Shp.Width
            End With
        Next Shp
    End With
End Sub

Hello! Thank you for all of your help!;

 W = Range(.PageSetup.Printarea).Width

Is causing issues and giving runtime error 1004, method "range of object" global failed.

 

[Yongle]

Post#11 Hi. I want every thing that is a "picture" to resize and fill the width of the print area

which suggests that you clicked on Set Print Area

BUT runtime error 1004, method "range of object" global failed at this line suggests that a Print Area is not set

 W = Range(.PageSetup.Printarea).Width

That is something for you to sort out

Whatever the cause of the error, replace that line with the one below and it should work for you

 W = Range("A:T).Width

 

[Pestomania]

So that worked! I did add in a last row option just by using row 32 (known).

Essentially

 H = Range("A" & lastrow & ":s32").Height

The only thing I haven't figured out is saying

Determining if the H or W exceeds pick the other one. Some pages gave landscape and other portrait pictures. So it would grow H to it's limits as long as W doesn't exceed their limits. And vice versa.