resize colums / rows in range
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!
|