VBAのTextBox自動調整マクロ | 質問

前へ 次へ
このQ&Aのポイント
  • VBAのフォーム上にTextBoxたくさんあるとき、文字の大きさを自動調整するマクロを使っています。しかし、TextBoxが多くなるため、プログラムが非常に長くなってしまいます。
  • 質問者は過去の質問などを参考に試してみましたが、うまくまとめられませんでした。どのような方法があるか、アドバイスを求めています。
  • VBAのフォーム上にTextBoxがたくさんあり、文字列の長さに応じてフォントサイズを自動調整するマクロを作成しています。しかし、TextBoxの数が多いため、プログラムが長くなってしまいました。どのようにまとめることができるかアドバイスをお願いします。
回答を見る
  • ベストアンサー

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

質問者が選んだベストアンサー

  • ベストアンサー
  • eden3616
  • ベストアンサー率65% (267/405)
回答No.1

http://okwave.jp/qa/q261042.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」を実際のテキストボックス名に合わせて変更してください

画像を拡大する
garasi0120
質問者

お礼

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

  1. カテゴリ
  2. ビジネス・キャリア
  3. 職種
  4. SE・インフラ・Webエンジニア

関連するQ&A

  • VBAのフォームでTextBoxがいっぱいある時

    Microsoft Excel 2000 for VBAのフォーム機能を使用して TextBox？に値が入力したらシートの指定したセルへ値が入るようにしたいんですが、 TextBoxがいっぱいあるため、以下のように非常に長いプログラムになってしまいました。 Private Sub TextBox1_Change() Sheets(sheetname).Cells(1, 横位置).Value = TextBox1.Value End Sub TextBox2～29は繰り返し Private Sub TextBox30_Change() Sheets(sheetname).Cells(30, 横位置).Value = TextBox30.Value End Sub 上手く配列化なんかでまとめる方法がありましたらアドバイスください。

  • エクセル　VBA　OptionButtonからTextBox

    すいません！ OptionButtonなら 下記の記述でエラー表示を 簡単にできるのですが これがOptionButtonではなく TextBoxならどのように変化したら 良いのでしょうか？ すいません、教えて下さい！ Private Sub 記録_Click() Dim i As Integer Dim Cnt As Integer Cnt = 0 For i = 1 To 6 Step 1 If Me.Controls("OptionButton" & i).Value Then Cnt = i Exit For End If Next i If Cnt = 0 Then MsgBox "選択されていません" Exit Sub End If If Me.Controls("Combobox" & Cnt).Value = "" Then MsgBox Me.Controls("OptionButton" & Cnt).Caption & " の内容が選択されていません" Exit Sub End If With 記入フォーム .TextBox5.Value = Me.Controls("OptionButton" & Cnt).Caption .TextBox6.Value = Me.Controls("Combobox" & Cnt).Value End With Unload Me End Sub

  • VBA ユーザーフォーム

    VBAにおけるユーザーフォームの件 今，下記の様なプログラムを組んでいるのですが，「myComboBox」に入った？値をこの後で使用したいのですが， どうすればいいのかわからなくて困っています． これで何がしたいかというと，ある個数分のコンボボックスを自動で作成して使用しようとしているのです． Private Sub UserForm_Initialize() Dim a As String Dim jj As Long Dim s As Integer Dim myComboBox As Control N = InputBox("抜き出したいデータ数は？") EffectiveRow = Range("A65536").End(xlUp).Row Effectivecolumn = Cells(2, 16384).End(xlToLeft).Column For s = 1 To N Set myComboBox = Me.Controls.Add("Forms.ComboBox.1") With myComboBox .Height = 20 .Width = 150 .Left = 120 .Top = (s - 1) * .Height + 10 End With For jj = 1 To Effectivecolumn myComboBox.AddItem Worksheets(1).Cells(1, jj).Value Next jj a = myComboBox.Value Worksheets(2).Cells(1, 1) = a Next s End Sub

  • VB6.0でのTextboxの高さ変更

    VB6.0を使用しています。 下記のようにテキストボックスを動的配置した際にボックスの高さを変更したいのですが、文字の大きさ等に依存しているよう？で変更できません。 よく似た質問でMultiline をTrueにするような物があり、試してみましたがエラーとなってしまいます。 もう少し小さくしたいのですが何を変更・追加すればよいのでしょうか？ どなたかご教授願います。 Private Sub Form_Load() Dim add_tbox As TextBox Set add_tbox = Controls.Add("VB.textbox", "text") With add_tbox .Text = "aaa" .Height = 240 '---テキストボックスの高さ .Left = 2270 .Top = 1700 .Width = 350 .FontSize = 9 '.MultiLine = False ---これを追加するとエラー"値の取得のみ可能なプロパティに値を設定する事はできません" .Visible = True End With MsgBox add_tbox.Height '---テキストボックスの高さ確認（270となっている） End Sub

  • エクセルに写真を挿入するVBA

    エクセルで写真集を作るためのVBAですが、以下のVBAでは画像がリンク貼り付けになってしまいます。どうしたらエクセルファイルに画像を貼りこみで保存できるのでしょうか？ よろしくお願いいたします。 やりたいことは、まずダブルクリックでダイアログボックスを表示させ、挿入したい写真を選択、写真がセルに合わせた大きさに縮小、セルの中央に写真を配置。以上です。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ 　　　　　　　　　　　　　　　　　　　　Cancel As Boolean) 　　Dim PicFile As Variant 　　Dim rX As Double, rY As Double 　　'［ファイルを開く］ダイアログボックスを表示 　　PicFile = Application.GetOpenFilename( _ 　　　　　　　　　　　　"画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp") 　　If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub 　　Application.ScreenUpdating = False 　　 　　'画像を挿入 　　With ActiveSheet.Pictures.Insert(PicFile) 　　　　rX = Target.Width / .Width 　　　　rY = Target.Height / .Height 　　　　If rX > rY Then 　　　　　　.Height = .Height * rY 　　　　Else 　　　　　　.Width = .Width * rX 　　　　End If 　　　　'セルの中央（横方向/縦方向の中央）に配置 　　　　.Left = Target.Left + (Target.Width - .Width) / 2 　　　　.Top = Target.Top + (Target.Height - .Height) / 2 　　End With 　　 　　Application.ScreenUpdating = True 　　Cancel = True End Sub

  • エクセルVBAのユーザーフォームにセルデータを

    Excel2007を使っています。 VBA初心者ですがユーザーフォームのテキストフォームにエクセル内のセルデータを表示させたいと考えています。 以下のコードをユーザーフォームのコードに書いてユーザーフォームを走らせましたがユーザーフォームは表示するのですがデータがまったく表示されません。 どなたかご教授いただけませんでしょうか。 Sub Farst() Dim Data1 As String Dim Data2 As String Dim Data3 As String Dim Data4 As String Dim Data5 As String Dim Data6 As String Dim Data7 As String Dim Data8 As String Dim Data9 As String Dim Data10 As String Dim ActiveRow As String ActiveRow = 4 With Worksheets("MDH,MDO") Data1 = .Cells(ActiveRow, 1) Data2 = .Cells(ActiveRow, 2) Data3 = .Cells(ActiveRow, 3) Data4 = .Cells(ActiveRow, 4) Me.TextBox1連番.Text = Data1 Me.TextBox2品番.Text = Data2 Me.TextBox3品番2.Text = Data3 Me.TextBox4品番3.Text = Data4 End With End Sub

  • ExcelVBA　TextBoxの値を取得できない

    Excel2010です。 2つのUserFormがあり（UserForm1・UserForm2とします）、UserForm1にはTextBox1～100を配置し、UserForm2にもTextBox1～150を配置しています。 それぞれのUserFormにおいて、そのUserForm名を変数に格納しておき、TextBoxの値を取得するコードを別のプロシージャ（「TextBoxチェック」）に書き、それを呼び出してTextBoxの値を格納しようとしましたができませんでした。 該当箇所のコードは以下のとおりです。 Public UFName As String 'UserFormの名前 Sub UserForm1処理() Const Num = 100 UFName = "UserForm1" Call TextBoxチェック(Num) End Sub Sub UserForm2処理() Const Num = 150 UFName = "UserForm2" Call TextBoxチェック(Num) End Sub Sub TextBoxチェック(Num As Integer) Dim i As Integer Dim Con As Control With UserForms.Add(UFName) For i = 1 To Num Set Con = .Controls("TextBox" & i) Debug.Print Con.Name Debug.Print .Controls("TextBox" & i).Value 　　（その他の処理のコードは省略） Next i End With End Sub 上のコードでは1つ目のDebug.Printの結果（TextBox名）は取得できていますが、2つ目のDebug.Printの結果（TextBoxの値）は空欄になってしまいます。 つまり、 With UserForms.Add(UFName)が、 Set Con = .Controls("TextBox" & i) では反映されているのに、 .Controls("TextBox" & i).Value では反映されていないということだと思います。 また、 Debug.Print .Controls("TextBox" & i).Value を Debug.Print UserForm1.Controls("TextBox" & i).Value とすると、UserForm1の値を取得できます。 また、 With UFName_UF を With UserForm1 にすると、 Debug.Print .Controls("TextBox" & i).Value の値は取得できます。 UserForm1とUserForm2において、TextBoxの値を取得する部分は共通しているため、その部分を別プロシージャにして呼び出して処理したいのですが、うまくいきません。 TextBoxの値を取得できない理由や、対処法が分かれば教えていただきたいです。

  • Excel VBA でグラフタイトルの位置変更

    　Excelで作成したグラフのタイトルの、（左の位置や幅は文字数で違ってくるので、）TopとHeightを、VBAを使って変更しようと思っています。 それで、以下のようなコードを書いてみたのですが、 「引数の数が一致しません　または不正なプロパティを使用しています」 とのエラーメッセージが出てしまい、実行できません。 ChartTitle.Left などの引数の型はDoubleのようなので、 ' Dim T, L, H, W As Double としてみましたが、変化はありません。 Sub ChangeChartTitlePos() 'Excel VBA でグラフタイトルの位置変更 ' Dim T, L, H, W As Double T = 2: L = 68.4: H = 26.4: W = 220 With ActiveChart.ChartTitle .Top = T .Height = H ' .Left = L ' .Width = W End With End Sub 　どなたか解決方法をご教授頂ければ幸いです。 　また、VBAを使わずにグラフのタイトルのTopとHeightを任意の値に変更する方法がありましたら、その方法も教えて頂ければと存じます。 　よろしくお願いします。 追記 　ちなみに、プロットエリアの変更は、以下のコードで処理できています。 Sub ChangePlotArea() With ActiveChart.PlotArea .Top = 36.4 .Left = 7 .Height = 190.6 .Width = 274.5 End With End Sub

  • セルの値をテキストボックスへ記入及び名前変更

    範囲選択したセルに丸オートシェイプを挿入すると共に、それぞれのセルの値をテキストで追加及び、図形名を同じ値にしたいと思っています（下記の＊＊＊の部分）。この時セルは結合されている場合があります。 描写は下記のようにしたのですが、セルの読み込みで詰まってしまいました。セルの値を読み込むにはどの様なしたらいいのでしょうか？ 宜しくお願い致します。 Sub 選択されたセルに丸テキスト挿入() Dim X As Double Dim Y As Double Dim L As Double Dim c As Range If Not TypeName(Selection) = "Range" Then Exit Sub For Each c In Selection With c.MergeArea If c.Address = .Item(1).Address Then L = IIf(.Width > .Height, .Height, .Width) X = .Left + (.Width - L) / 2 Y = .Top + (.Height - L) / 2 ActiveSheet.Shapes.AddShape(msoShapeOval, X, Y, L, L).Select Selection.Name = ＊＊＊ Selection.Characters.Text = "＊＊＊" Selection.ShapeRange.Fill.Visible = msoFalse 　　 　　Selection.HorizontalAlignment = xlCenter With Selection.Characters(Start:=1, Length:=3).Font .Size = 8 End With End If End With Next End Sub

  • エクセル２０１０　挿入画像の圧縮　VBA

    お世話になります。 エクセル２０１０を使用しています。写真帳を作成しダブルクリックすれば写真が挿入されるようVBAにて作成しましたが、写真の解像度が高いので挿入するたびに画像が圧縮するようにVBAを組みたいのですが、どなたかご教示ください。 具体的には一同挿入した画像を一度コピーし、再度貼り付ける・・・という動作かなと考えているのですが、マクロの記憶では記録されず・・・困っております。 現在の写真帳の構文は Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean) Dim myF As Variant Dim mySp As Object Dim myAD1 As String Dim myAD2 As String Dim myHH As Double Dim myWW As Double Dim myHH2 As Double Dim myWW2 As Double '挿入のセルを指定 If Application.Intersect(Target, Range("d6,d23,d40")) Is Nothing Then Exit Sub Cancel = True Application.ScreenUpdating = False End If '写真挿入 Next myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If myPic = False Then MsgBox "画像を選択してください" Exit Sub End If Set myRange = Target 'このセル範囲に収まるように画像を縮小する Application.ScreenUpdating = False With ActiveSheet.Shapes.AddPicture(myPic, False, True, myRange.Left, myRange.Top, myRange.Width, myRange.Height) rX = 0.85 rY = 1 If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置 .Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置 .ZOrder msoSendToBack '最背面へ移動 End With Application.ScreenUpdating = True Cancel = True End Sub 上記に.CUT　などを書き足せばよいのか・・・ →エラーばかりで動かなったので。。 　こちらに質問することにしました。 どうぞ、よろしくお願いします。

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する