Re: resize colums / rows in range

Tech Tip: Click here to run a free scan for Windows Errors and optimize PC performance

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.Work***.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!
>
.

Quantcast