VBA リストボックスの表示について

ユーザーホーム上でリストボックスの中に表示される文字数を制限したいです

エクセル/VBAでユーザーホームを使った検索機能をつくり
検索した結果をリストボックスに表示して選択すると詳細が出る
というものを作成したのですが文字数が多いものは枠から
はみ出る形で見栄えが悪いので表示するときのみ文字数を制限したいのでしょうか？
出来るのであれば下記の画像のようにしてみたいと思ってます。

ソースコードはネットのサンプルを少し治したものになります

該当のソースコード!

Option Explicit
'連絡ツールのリストボックス
Private Sub UserForm_Initialize()
With ContactTool
.AddItem "電話"
.AddItem "Cメール"
.AddItem "社内メール"
.AddItem "Line"
.AddItem "Slack"
.AddItem "その他"
End With

End Sub

'登録確認
Private Sub Registration_Click()

If UserForm1.NameBox.Value = "" Or UserForm1.TextBox1.Value = "" Then
MsgBox "未入力があります"
Else
Call UserForm1.Registration_Click2

End If

End Sub
'エクセルに登録
Sub Registration_Click2()
Dim Name As Long
Dim rc As VbMsgBoxResult

Name = 1

Do Until Cells(Name, 1) = ""
Name = Name + 1
Loop

rc = MsgBox("登録しますか？", vbYesNo + vbQuestion)


If rc = vbYes Then
MsgBox "登録しました", vbInformation
Worksheets("sheet1").Cells(Name, 1).Value = Format(Now, "mm月dd日　hh時")
Worksheets("sheet1").Cells(Name, 2).Value = UserForm1.Affiliation.Value
Worksheets("sheet1").Cells(Name, 3).Value = UserForm1.NameBox.Value
Worksheets("sheet1").Cells(Name, 4).Value = UserForm1.ContactTool.Value
Worksheets("sheet1").Cells(Name, 5).Value = UserForm1.TextBox1.Value
Affiliation.Value = ""
NameBox.Value = ""
ContactTool.Value = ""
TextBox1.Value = ""
Else
MsgBox "処理を中止します", vbCritical
End If

End Sub

'検索を実行します。部分一致検索を行っています。
'Private Sub Search_Click()

'If SearchBox.Value = "" Then
'MsgBox "データがありません"
'Else
'Call UserForm1.Search_Click2
'End If
'End Sub

Sub Search_Click()

Dim lastRow As Long
Dim myData, myData2(), myno
Dim i As Long, j As Long, cn As Long

Workbooks("営業用メモV3.xlsm").Activate

'検索するデータを配列　myData　に格納しています。
With Worksheets("Sheet1")
lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
myData = .Range(.Cells(1, 1), .Cells(lastRow, 5)).Value
End With

'配列　myData の中で検索で一致したデータを配列　myData2　に格納しています。
ReDim myData2(1 To lastRow, 1 To 5)
For i = LBound(myData) To UBound(myData)
If myData(i, 2) Like "*" & SearchBox.Value & "*" And myData(i, 3) Like "*" & SearchBox2.Value & "*" Then
cn = cn + 1
myData2(cn, 1) = myData(i, 1)
myData2(cn, 2) = myData(i, 2)
myData2(cn, 3) = myData(i, 3)
myData2(cn, 4) = myData(i, 4)
myData2(cn, 5) = myData(i, 5)
End If
Next i

'検索で一致したデータをリストボックスに表示
With ListBox1
.ColumnCount = 5
.ColumnWidths = "88;40;55;60;50"
.List = myData2
End With

End Sub
'リストボックスの詳細を表示
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
With ListBox1
If .ListIndex = -1 Then
MsgBox "未選択です。"
Else
MsgBox .List(.ListIndex, 4), Title:="メモ詳細"
End If
End With
End Sub

Private Sub end_Button_Click()
Unload UserForm1
If (Workbooks.Count = 1) Then
' 開いているブックが自身のみの場合はExcelを終了させる
ThisWorkbook.Save
Application.Quit
End If

ThisWorkbook.Save
Workbooks("営業用メモV3.xlsm").Close
End Sub

sinzou

2020/06/15 13:56

セルに代入される文字列が長いから、最初の何文字かにする？ですかね。

ttyp03

2020/06/16 00:41

×ホーム〇フォームリストボックスの中に表示される文字数を制限したい文字数がはみ出るのはUserForm1.TextBox1.Value なんか言ってることが矛盾しているのですが。リストボックスにはTextBox1に入力したものが表示されるということでしょうか？入力する文字数を制限したいのか、そちらはそのままで表示するときのみ文字数を制限したいのでしょうか？

kano_036

2020/06/16 01:13

ttyp03様説明があやふやで申し訳ありません。やりたいことは後者の表示するときのみ文字数を制限したいのですができますでしょうか？

ttyp03

2020/06/16 01:22

リストボックスの処理を提示していただければ検討します。

kano_036

2020/06/16 01:29

ttyp03様見づらいかとは思いますがソースコードの全容です Option Explicit '連絡ツールのリストボックス Private Sub UserForm_Initialize() With ContactTool .AddItem "電話" .AddItem "Cメール" .AddItem "社内メール" .AddItem "Line" .AddItem "Slack" .AddItem "その他" End With End Sub '登録確認 Private Sub Registration_Click() If UserForm1.NameBox.Value = "" Or UserForm1.TextBox1.Value = "" Then MsgBox "未入力があります" Else Call UserForm1.Registration_Click2 End If End Sub 'エクセルに登録 Sub Registration_Click2() Dim Name As Long Dim rc As VbMsgBoxResult Name = 1 Do Until Cells(Name, 1) = "" Name = Name + 1 Loop rc = MsgBox("登録しますか？", vbYesNo + vbQuestion) If rc = vbYes Then MsgBox "登録しました", vbInformation Worksheets("sheet1").Cells(Name, 1).Value = Format(Now, "mm月dd日　hh時") Worksheets("sheet1").Cells(Name, 2).Value = UserForm1.Affiliation.Value Worksheets("sheet1").Cells(Name, 3).Value = UserForm1.NameBox.Value Worksheets("sheet1").Cells(Name, 4).Value = UserForm1.ContactTool.Value Worksheets("sheet1").Cells(Name, 5).Value = UserForm1.TextBox1.Value Affiliation.Value = "" NameBox.Value = "" ContactTool.Value = "" TextBox1.Value = "" Else MsgBox "処理を中止します", vbCritical End If End Sub '検索を実行します。部分一致検索を行っています。 'Private Sub Search_Click() 'If SearchBox.Value = "" Then 'MsgBox "データがありません" 'Else 'Call UserForm1.Search_Click2 'End If 'End Sub Sub Search_Click() Dim lastRow As Long Dim myData, myData2(), myno Dim i As Long, j As Long, cn As Long Workbooks("営業用メモV3.xlsm").Activate '検索するデータを配列　myData　に格納しています。 With Worksheets("Sheet1") lastRow = .Cells(Rows.Count, 1).End(xlUp).Row myData = .Range(.Cells(1, 1), .Cells(lastRow, 5)).Value End With '配列　myData の中で検索で一致したデータを配列　myData2　に格納しています。 ReDim myData2(1 To lastRow, 1 To 5) For i = LBound(myData) To UBound(myData) If myData(i, 2) Like "*" & SearchBox.Value & "*" And myData(i, 3) Like "*" & SearchBox2.Value & "*" Then cn = cn + 1 myData2(cn, 1) = myData(i, 1) myData2(cn, 2) = myData(i, 2) myData2(cn, 3) = myData(i, 3) myData2(cn, 4) = myData(i, 4) myData2(cn, 5) = myData(i, 5) End If Next i '検索で一致したデータをリストボックスに表示 With ListBox1 .ColumnCount = 5 .ColumnWidths = "88;40;55;60;50" .List = myData2 End With End Sub 'リストボックスの詳細を表示 Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) With ListBox1 If .ListIndex = -1 Then MsgBox "未選択です。" Else MsgBox .List(.ListIndex, 4), Title:="メモ詳細" End If End With End Sub Private Sub end_Button_Click() Unload UserForm1 If (Workbooks.Count = 1) Then ' 開いているブックが自身のみの場合はExcelを終了させる ThisWorkbook.Save Application.Quit End If ThisWorkbook.Save Workbooks("営業用メモV3.xlsm").Close End Sub

ttyp03

2020/06/16 01:34

質問は編集できるので、できればそちらに貼ってください。

kano_036

2020/06/16 01:37

ttyp03様かしこまりました。

ttyp03

2020/06/16 01:55

何度も申し訳ないですが、コードはコードタグで括ってください。

ttyp03

2020/06/16 02:06

ああああああ、のところを見映え良くしたいということですよね？ 2行目のような感じでいいんですかね？途中でカットして...を付ける。どうでもいいですけど、背景がすごいｗ

行動規範の内容に同意します

回答3件

記入ミスです。削除します。

投稿2020/06/17 01:24

編集2020/06/17 01:25

tosi

総合スコア553

ベストアンサー

先走って回答しておきます。
見た目12文字より長い場合カットすればよいかと思うので、myData2(cn, 5)への代入処理を次のようにしてみてはいかがでしょうか。

VBA
1If Len(myData(i, 5)) > 12 Then
2	myData2(cn, 5) = Left(myData(i, 5), 12) & "..."
3Else
4	myData2(cn, 5) = myData(i, 5)
5End If
6

投稿2020/06/16 02:15

ttyp03

総合スコア17000

kano_036

2020/06/16 03:14

ttyp03様のコードに書き換えたら思い通りの状態になりましたありがとうございます！！

行動規範の内容に同意します

UserForm1.TextBox1への入力時に文字数制限するのであればこんな感じです。

VBA
1'
2'(Test_Sample_Miniature)
3'
4Private strWork As String
5
6Private Sub TextBox1_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
7    If Len(Me.TextBox1.Text) > 5 Then
8        MsgBox "入力文字は5文字以内"
9        Me.TextBox1.Text = strWork
10        Cancel = True
11    End If
12End Sub
13
14Private Sub TextBox1_Enter()
15    strWork = Me.TextBox1.Text
16End Sub