Excelのセルのフォントサイズを自動調整

Excel97VBAの質問です。
セルの値が長すぎて表示しきれない場合は、フォントサイズを調整したい。

Sub Macro1()
With Sheet1
.Columns("A").ColumnWidth = 1
.Range("A1").Value = 1
.Range("A2").Value = 12
.Range("A3").Value = 123
.Range("A4").Value = 1234
End With
End Sub

この場合、A2～A4の表示が潰れます。

フォントサイズを例えば、

Sub Macro2()
.Range("A2").Font.Size = 7
.Range("A3").Font.Size = 5
.Range("A4").Font.Size = 3
End Sub

と設定すれば潰れずに値が表示されます。
このようなフォントサイズの最適値を自動的に設定したい。
よろしくご指導お願いします。

No.1 ベストアンサー 回答者： 2002pon 回答日時： 2002/08/05 21:10

こんにちは

マクロではないのですが、
「セルの書式設定－配置－縮小して全体を表示する」
ではだめなのでしょうか？

No.2 回答者： imogasi 回答日時： 2002/08/05 21:52

ご質問と逆のColumnWidthを広げるAutoFitはありますが、

FontSizeを拡大縮小するメソッドはないと思います。
文字数を取得して、Case文などで文字数の段階で何段階かのフォントをセットするより他の方法はないのでは。RangeオブジェクトにAutoFormatメソッドがあるが、書式を自動的に設定
するが、自動の意味が違う。＃１の方の解答は、２行以上に
おり返すが、Fontの大きさは縮めない。.WrapText = True
に当たります。

No.3 回答者： 2002pon 回答日時： 2002/08/05 21:59

#1のものです。

補足です。

「セルの書式設定－配置－縮小して全体を表示する」
は、
.ShrinkToFit = True
でして、２行には折り返しません。
.WrapText = True は、
「セルの書式設定－配置－折り返して全体を表示する」
です。

この回答へのお礼

ありがとうございます。
.ShrinkToFit = True
でＯＫです。
MergeCellsしても希望どうり動いてくれました。

お礼日時：2002/08/06 15:37

No.4 回答者： imogasi 回答日時： 2002/08/05 22:27

#2で解答を入れた者です。

＃１の2002ponさんのご解答を「.WrapText = True」と誤解しました。ご解答者とご質問者にお詫びいたします。また方法がないとしましたが誤りです。
結論は「.ShrinkToFit = True」があるが正解のようです。今後とも勉強します。
ただ半角英字ではフォントサイズが小さくなり過ぎて、使えるのかなと心配しました。

No.5 回答者： nishi6 回答日時： 2002/08/06 00:18

セルの値は『数値』としています。

そのため、まず、NumberFormatLocal で数値の書式を指定し、指数表示にならなようにしています。
後は、フォントサイズを操作しています。
オーバーフロー？して『#』を含んだ表示ならフォントサイズを小さくしています。
その時のフォントサイズの減少幅は『1』としています。

AutoFitで列幅をいじったり、ShrinkToFitで見せかけの変更ではフォントを操作できないので、
下のマクロでは『Font.Size』のみを使っています。

質問にあるA1～A4を選択状態にして下のマクロを実行してみました。(Excel2000です)
フォントや数値によって、質問にあるA2、A3、A4の7、5、3は7、5、4になったりもするようです。
質問ではA1のフォントサイズについて触れられていませんが、A2、A3、A4とは違って、逆にフォントを大きくしていく必要はないでしょうか。この点については質問に触れられていないので操作していません。対応は簡単でしょう。


Sub FontFit()
　　Dim rg As Range 'セル

　　For Each rg In Selection
　　　　With rg
　　　　　　.NumberFormatLocal = "0"
　　　　　　While Left(.Text, 1) = "#" And .Font.Size > 0
　　　　　　　　.Font.Size = .Font.Size - 1
　　　　　　Wend
　　　　End With
　　Next
End Sub

この回答へのお礼

ありがとうございます。
すばらしいロジックです。
しかし、1行で解決する方法がありました。

お礼日時：2002/08/06 15:50