こんにちは、Dancing Shigekoです！
引き続き、スケジュール表作りに挑戦中。→前回
自動でテキストボックスを表示させられるようになったので、今度は複数行で同じように入力できるように改造。
早速、ChatGPTのアドバイスを受けて以下のプログラムに変更。
---
Private Sub Worksheet_Change(ByVal Target As Range)
Dim txt As String
Dim tb As Shape
Dim cell As Range
Dim tempShape As Shape
Dim tempWidth As Double
Dim tempHeight As Double
Dim padding As Double
Dim maxWidth As Double
Dim totalHeight As Double
' A1:C10の変更を監視
If Not Intersect(Target, Me.Range("A1:C10")) Is Nothing Then
' テキストボックスが存在するか確認
On Error Resume Next
Set tb = Me.Shapes("MyTextBox")
On Error GoTo 0
' テキストボックスが存在しない場合は作成
If tb Is Nothing Then
Set tb = Me.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 100, 200, 50)
tb.Name = "MyTextBox"
End If
' A1:C10の内容を取得してテキストボックスに設定
txt = ""
For Each cell In Me.Range("A1:C10")
If cell.Value <> "" Then
txt = txt & cell.Value & vbCrLf
End If
Next cell
' 最後の改行を削除
If Len(txt) > 0 Then
txt = Left(txt, Len(txt) - 2)
End If
tb.TextFrame.Characters.Text = txt
' 一時的なテキストボックスを作成してサイズを計算
Set tempShape = Me.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 0, 0)
tempShape.TextFrame.Characters.Text = txt
tempShape.TextFrame.AutoSize = True
tempWidth = tempShape.Width
tempHeight = tempShape.Height
tempShape.Delete
' パディングを追加
padding = 10
' テキストボックスのサイズを設定
tb.Width = tempWidth + padding
tb.Height = tempHeight + padding
End If
End Sub
---
さて、実際に入力してみた。
ところが・・・
二行目のセルの内容も同一のテキストボックスの中に表示される。
期待していた作りにならなかったので、再調整。
このあと、だいぶ苦戦するのであった。
挑戦はまだまだ続く。
乞うご期待！
Comments