VBAのフォーム上にTextBoxたくさんあるとき

Microsoft Excel 2013 の VBAのフォーム機能を利用してます。
TextBoxにセルを参照して文字が入ってくるようにしています。、
参照するセルによって文字列の長さが違うので
文字の大きさを自動調整してくれるマクロを使っているのですが
TextBoxがいっぱいあるため、以下のように非常に長いプログラムになってしまいました。

Private Sub textBox1_Change()
Const InitialFontSize As Double = 40 '初期フォントサイズ
Dim BufWidth As Double
Dim BufHeight As Double
With Me.TextBox1
.Font.Size = InitialFontSize
BufWidth = .Width
BufHeight = .Height
.AutoSize = True
While .Width > BufWidth
.Font.Size = .Font.Size - 2.5
Wend
.AutoSize = False
.Width = BufWidth
.Height = BufHeight
End With
End Sub

TextBox2～67は繰り返し

Private Sub textBox67_Change()
Const InitialFontSize As Double = 40 '初期フォントサイズ
Dim BufWidth As Double
Dim BufHeight As Double
With Me.TextBox67
.Font.Size = InitialFontSize
BufWidth = .Width
BufHeight = .Height
.AutoSize = True
While .Width > BufWidth
.Font.Size = .Font.Size - 2.5
Wend
.AutoSize = False
.Width = BufWidth
.Height = BufHeight
End With
End Sub

過去の質問等を参考にいろいろ試してみたのですが
自分の力不足でうまくできませんでした。
うまくまとめられるような方法等ありましたらお知恵を拝借できないでしょうか
よろしくお願い致します

No.1 ベストアンサー 回答者： eden3616 回答日時： 2014/09/09 21:08

http://oshiete.goo.ne.jp/qa/261042.html
ほぼ、この回答者様のコードのままですが。。。

以下のコードはテキストボックス8個「TextBox1～8」を
「UserForm1」に配置した場合となります。


■標準モジュールを挿入して、以下のコードを貼付
　　（フォームを表示するためだけのものです）

Sub フォーム表示()
　　Load UserForm1
　　UserForm1.Show vbModeless
End Sub


■クラスモジュールを挿入して、以下のコードを貼付

Private WithEvents myText As MSForms.TextBox
Private myIndex As Integer

Public Sub S_setText(NewText As MSForms.TextBox, Index As Integer)
　　Set myText = NewText
　　myIndex = Index
End Sub

Private Sub myText_Change()
Const InitialFontSize As Double = 40
Dim BufWidth As Double
Dim BufHeight As Double
With UserForm1.Controls("TextBox" & myIndex) '★
　　.Font.Size = InitialFontSize
　　BufWidth = .Width
　　BufHeight = .Height
　　.AutoSize = True
　　While .Width > BufWidth
　　　　.Font.Size = .Font.Size - 2.5
　　Wend
　　.AutoSize = False
　　.Width = BufWidth
　　.Height = BufHeight
End With
End Sub


■ユーザーフォームのコードに以下のコードを貼付

Private myTextArray(1 To 8) As New Class1 '☆

Private Sub UserForm_Initialize()
　　Dim i As Integer
　　For i = 1 To 8 '☆
　　　　myTextArray(i).S_setText UserForm1.Controls("TextBox" & i), i '★
　　Next
End Sub


■貼り付けたコードの修正

末尾が☆の2箇所の「8」を実際のテキストボックスの数に合わせて変更してください
末尾が★の2箇所の「UserForm1」を実際のユーザーフォーム名に合わせて変更してください
末尾が★の2箇所の「TextBox」を実際のテキストボックス名に合わせて変更してください

この回答へのお礼

忙しい中ありがとうございます。
わかりやすく修正個所も書いてあったので
とても助かりました。
ありがとうございました。

お礼日時：2014/09/17 23:17