Macro to reduce everything by %

[tonywatsonhelp]

Hi Everyone,
It official, im an idiot! please help if you can,
Just finished building out staff rota and realised everything has been built at 50% zoom page size,
so when i make it 100% zoom its massive!

this would be fine id leave it like this but i needed to add in two dropdown boxes and they are tiny!
so here's what i need,

a macro to resize everything by 50% (if i could change this even better as i could experiment,
when i say everything i guess i mean, all font sizes, all column widths and all row heights (anything else you can think of)
i would do this manually but it a big sheet with lost of different column, row sizes and font sizes,

if anyone know how to do this you might just save me from chucking myself off the pier! lol

Thanks

Tony

 

[Michael M]

You mean like this

Sub MM1()
    ActiveWindow.Zoom = 150
End Sub

 

[tonywatsonhelp]

No, but thank for trying lol,
no what i mean is a macro to actully reduce everything on the page by 50%
so if cell A1 has a font of 20 it should be 10, coulmn is 30 it should be 15 row hight 25 it should be 12.5 for the entire sheet?
anyone know if this could even be done?

 

[Michael M]

So Maybe this way, but it will only do the font....you probably need to more specific for other changes !!

Sub MM1()
'adapted from code by @Jomili
Dim Number As Variant, FS As Variant, cell As Range
On Error Resume Next
Number = InputBox("Enter the Increment/Decrement Percent" & vbCrLf & _
                    "Greater than 1 to increase, less than 1 to Decrease", "Value to Change By")
Application.ScreenUpdating = False
    For Each cell In ActiveSheet.UsedRange
        FS = cell.Font.Size
        cell.Font.Size = FS * Number
    Next cell
Application.ScreenUpdating = True
End Sub

 

[tonywatsonhelp]

thank you micheal, this is great,
just what i need

 

[Michael M]

Glad to help...This will do the columns and rows as well

Sub MM1()
Dim Number As Variant, FS As Variant, cell As Range, c As Integer, columnwidth As Integer, m As Integer, r As Long, h As Integer
Dim lr As Long, Lc As Integer
lr = Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
Lc = Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column

Number = InputBox("Enter the Increment/Decrement Percent" & vbCrLf & _
                    "Greater than 1 to increase, less than 1 to Decrease", "Value to Change By")
Application.ScreenUpdating = False
    For Each cell In ActiveSheet.UsedRange
        FS = cell.Font.Size
        cell.Font.Size = FS * Number
    Next cell
 m = Columns(1).columnwidth
For c = 1 To Lc
        Columns(c).columnwidth = m * Number
Next c
h = Rows(1).RowHeight
For r = 1 To lr
        Rows(r).RowHeight = h * Number
Next r
Application.ScreenUpdating = True
End Sub