View Single Post
  #8   Report Post  
Posted to microsoft.public.excel.programming
okaizawa okaizawa is offline
external usenet poster
 
Posts: 129
Default 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!