resize colums / rows in range

Although I am not sure what you mean by 'sees',


loop through the columns and reduce the columnwidth by 1/9. loop through
the rows and reduce the rowheight by 1/9.

if that is what you want. (maybe you meant multiply by .9). You might need
to adjust the font size as well.

--
Regards,
Tom Ogilvy


"philcud" <philcuddy@gmail.com> wrote in message
news:1122383009.782111.64220@z14g2000cwz.googlegroups.com...
> the application that opens the spreadsheet 'sees' the spreadsheet at
> 100% zoom, so unfortunatley need to resize rows and colums..
>

yep, exactly, loop through rows and colums in selection and reduce
height / width by 1/9th.

many thanks.

perhaps you thought i was ok with the logic, but unfortunately i cannot
write the code!!
if someone could post the necessary code please!

Sub ABEF()
For Each col In ActiveSheet.UsedRange.Columns
w = col.ColumnWidth
w = (8 / 9) * w
col.ColumnWidth = w
Next
For Each rw In ActiveSheet.UsedRange.Rows
h = rw.RowHeight
h = (8 / 9) * h
rw.RowHeight = h
Next
End Sub

Of course this would assume the aspect ratio is 1, which it isn't, so you
might need to reduce rows less than columns I think.

--
Regards,
Tom Ogilvy



"philcud" <philcuddy@gmail.com> wrote in message
news:1122393630.638802.22950@o13g2000cwo.googlegroups.com...
> perhaps you thought i was ok with the logic, but unfortunately i cannot
> write the code!!
> if someone could post the necessary code please!
>

Hi,
i wrote some code below.
this macro converts size simply. but actual size is rounded in pixels.
so, total height and width might be different from expected.

Sub Test()
ZoomRange Selection, 9 / 10, 9 / 10
End Sub

Sub ZoomRange(target_range As Range, px As Double, py As Double)
Dim cw() As Double, rh() As Double
Dim w1 As Double, w2 As Double, tmp As Double
Dim i As Long
Dim r As Range

Set r = target_range.Areas(1)
On Error Resume Next
Application.EnableEvents = False
r.Worksheet.Activate
r.Select
Application.EnableEvents = True

On Error GoTo ErrorHandler
If MsgBox("Macro is changing size of cells. You cannot undo. Continue?", _
vbOKCancel Or vbExclamation) <> vbOK Then Exit Sub

Application.ScreenUpdating = False

'for conversion from points to number of characters
With r.Columns(1)
tmp = .ColumnWidth
.ColumnWidth = 1: w1 = .Width
.ColumnWidth = 2: w2 = .Width
.ColumnWidth = tmp
End With

ReDim cw(1 To r.Columns.Count)
ReDim rh(1 To r.Rows.Count)

For i = 1 To UBound(cw)
tmp = r.Columns(i).Width * px
If tmp > w1 Then
cw(i) = (tmp - w1) / (w2 - w1) + 1
Else
cw(i) = tmp / w1
End If
If cw(i) > 256 Then
MsgBox "Column width too large.", vbExclamation
Exit Sub
End If
Next
For i = 1 To UBound(rh)
rh(i) = r.Rows(i).Height * py
If rh(i) > 409 Then
MsgBox "Row height too large.", vbExclamation
Exit Sub
End If
Next

'set columnwidth
For i = 1 To UBound(cw)
r.Columns(i).ColumnWidth = cw(i)
Next
'set rowheight
For i = 1 To UBound(rh)
r.Rows(i).RowHeight = rh(i)
Next

Application.ScreenUpdating = True
Exit Sub

ErrorHandler:
MsgBox Error(Err), vbExclamation
Exit Sub
End Sub

--
HTH,

okaizawa


philcud wrote:
> perhaps you thought i was ok with the logic, but unfortunately i cannot
> write the code!!
> if someone could post the necessary code please!
>

many thanks tom and oakaizawa.
you have probably saved me 2 days work with your code (the workbook had
dozens of sheets)
i really dont know whether google groups should make me this happy, but
it has!!