Post-Admin:
Date: 2006年 10月 10日
Subject: 続・Excelでセル内の全体を表示する
セルの書式で「折り返して全体を表示する」と「縮小して全体を表示する」に両方チェックが入っている場合にそれを同時に実現する。
の改良版




'ThisWorkbookに書く
Private Sub autoSetFontSize(ByVal Target As Range)
Dim orgorgOrientation
Dim orgOrientation
Dim tmpOrientation
Dim orgWidth
Dim orgColumnWidth
Dim orgHeight
Dim orgFontSize
Dim maxFontSize2
Dim typFontSize2
Dim minFontSize2
Dim bigFlg
Dim tmp1

Application.ScreenUpdating = False
On Error Resume Next
orgWidth = Target.Width
orgColumnWidth = Target.ColumnWidth
orgHeight = Target.RowHeight
orgOrientation = Target.Orientation
orgorgOrientation = Target.Orientation
Select Case orgOrientation
Case xlDownward
orgOrientation = -90
Case xlHorizontal
orgOrientation = 0
Case xlUpward
orgOrientation = 90
Case xlVertical
orgOrientation = -90
End Select

orgFontSize = Target.Font.Size
maxFontSize2 = orgFontSize * 2 + 1
If maxFontSize2 < 23 Then maxFontSize2 = 23
minFontSize2 = 2

Do
typFontSize2 = Int((maxFontSize2 + minFontSize2) / 2)
Target.Font.Size = typFontSize2 / 2
bigFlg = 0

Target.Orientation = orgOrientation
Target.Columns.AutoFit
If Target.Width > orgWidth Then bigFlg = 1

Target.RowHeight = orgWidth
tmpOrientation = orgOrientation + 90
If tmpOrientation > 90 Then tmpOrientation = tmpOrientation - 180
Target.Orientation = tmpOrientation
Target.ColumnWidth = orgHeight / orgWidth * orgColumnWidth
tmp1 = Target.Width
Target.Columns.AutoFit
'If Target.Width > orgHeight Then bigFlg = 1
If Target.Width > tmp1 Then bigFlg = 1
Target.RowHeight = orgHeight

If bigFlg > 0 Then
maxFontSize2 = typFontSize2
Else
minFontSize2 = typFontSize2
End If
Loop While maxFontSize2 > minFontSize2 + 1

Target.Font.Size = minFontSize2 / 2
Target.Orientation = orgorgOrientation
Target.ColumnWidth = orgColumnWidth
Target.RowHeight = orgHeight
Application.ScreenUpdating = True
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim c
For Each c In Target
If c.WrapText And c.ShrinkToFit Then autoSetFontSize c
Next
End Sub

'再計算されたセルも考慮する
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim c
Dim i
Dim r As Range
For i = 1 To Sh.Columns.Count
Set r = Sh.Range(Sh.Cells(1, i), Sh.Cells(Sh.Rows.Count, i).End(xlUp))
For Each c In r
If c.WrapText And c.ShrinkToFit Then autoSetFontSize c
Next
Next
End Sub

[PR]
by noaccess | 2006-10-10 21:22


Profile:
ほんとうかなあ?
by noaccess
プロフィールを見る
画像一覧

Calender:
S M T W T F S
1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30

*: 検索




*: 最新のトラックバック
うげ!
from ぶろぐ、ぶろぐとき、ぶろげば..
えーと
from ぶろぐ、ぶろぐとき、ぶろげば..
あれ
from ぶろぐ、ぶろぐとき、ぶろげば..

*: メモ帳
ぎゃふん状態にある


*: ブログジャンル
つぶやき

*: 画像一覧