テキストボックスの横幅はそのままで高さだけ文字列に合わせて調節するマクロ

テキストボックスのサイズの調整で横幅はそのままで、高さだけ文字列に調整したい

文字列の下に開いた空白やはみ出た文字をピッタリテキストボックスに収めたい

こうしたかった

こういう手動はイヤ、ピッタリにしたい

サイズの調節の設定は

右クリックメニューからテキスト効果の設定で

f:id:gogowaten:20191018155231p:plain

自動調整のテキストに合わせて図形のサイズを調整するにチェックを入れると

こうなる、改行のない文字列だからこうなるのが自然だけど

求めているのと違う

ぐぐってみたけどそれらしい設定は見つからなかった

マクロを色々いじっていたらあった

Shape.TextFrame2.AutoSize = msoAutoSizeShapeToFitText

この前のフォント指定に続き、またしてもTextFrame2にあった

これを使うと横幅はそのままで高さだけピッタリに調節される

マクロに用意されているってことは、どこかにその設定があっても良さそうなんだけどねえ

選択されている図形に文字があったら図形の高さを文字に合わせるマクロ

Sub tatepittanテキストボックスの高さの調整()
'横幅そのままで高さを文字に合わせる
'テキストボックスなど文字のある図形を選択して実行
    On Error Resume Next
    
    Dim sr As ShapeRange
    Set sr = Selection.ShapeRange
    
    For i = 1 To sr.Count
        With sr.Item(i)
        '文字がない図形は無視、図形とテキストボックス以外も無視
            If .TextEffect.text <> "" Then
                If .Type = msoAutoShape Or .Type = msoTextBox Then
                    .TextFrame2.AutoSize = msoAutoSizeShapeToFitText
                End If
            End If
        End With
    Next
    
End Sub

この高さ調節のマクロを使って作ったのが次のマクロ

選択セルの値を使って見出しと本文の2つのテキストボックス作成して

グループ化するマクロ

選択しておくセルはひとつ、または一列の状態で実行、これが見出しになる

選択セルの右のセルの値が本文になる

f:id:gogowaten:20191018155249p:plain

見出し(タイトル)にしたいセルを選択してマクロを実行すると

f:id:gogowaten:20191018155257p:plain

見出しと本文のテキストボックスが作成される

重なっているから広げてみると

f:id:gogowaten:20191018155308p:plain

こういうのが作ってみたかった、なお使い道は不明

中身は2つの図形で青色の見出しの部分は正確に言うと

テキストボックスではなくて四角形(Rectangle)の図形でできている、

本文のほうはテキストボックス(textbox)でできている

この2つを組み合わせてグループ化している

なんで見出しは四角形の図形にしたのか

図形を移動したいとき、テキストボックスを掴んでドラッグしようとすると

文字列の選択状態になってしまって移動できない、けど

図形の四角形なら

文字以外の場所なら、そのままドラッグで移動できる！

…

だったら本文のほうも図形の四角形にしたほうがいいのかな

選択セルの値を使って見出しと本文の2つのテキストボックス作成して

グループ化するマクロ

Public Sub セルの値でタイトルつきテキストボックス()
'一列か1つのセルを選択した状態で実行
'選択セルの値でタイトル(見出し)部分を作成して、選択セルの右のセルの値で本文を作る
    Dim s As Shape
    Dim tb As Shape 'As TextBox
    Dim r As Range
    Dim ssName(1) As String
    Dim ASh As Worksheet
    Dim i As Long, mozisuu As Long
    Dim tCell As Range
    Dim sr As ShapeRange
    Const ShapeWidth As Single = 160 '図形の横幅
    
    Set ASh = ActiveSheet

    If TypeName(Selection) <> "Range" Then Exit Sub 'セルが選択されていなければここで終わり
    Set r = Selection    
    For i = 1 To r.Rows.Count
        Set tCell = r.Cells(i, 1)
        
    'タイトル部分(四角形)作成
        Set s = ASh.Shapes.AddShape(msoShapeRectangle, _
            tCell.Left, tCell.Top, tCell.Width, tCell.Height)
        ssName(0) = s.Name '名前を配列に入れる
        
        With s.TextFrame
            .HorizontalAlignment = xlHAlignCenter   '水平位置中央
            .VerticalAlignment = xlVAlignCenter     '垂直位置中央
            .Characters.text = tCell.Value
            mozisuu = .Characters.Count
        End With
        
        With s
            .Line.Weight = 0.1 '枠の太さ
            .Width = ShapeWidth
'            .Select
        End With
        
        With s.TextFrame2.TextRange.Characters(1, mozisuu).Font
'            .Name = r.Font.Name         'フォント指定(2015/06/15修正)
'            .NameFarEast = r.Font.Name  '日本語のフォント指定
'            .Size = r.Font.Size         'フォントサイズ

            .Name = tCell.Font.Name         'フォント指定
            .NameFarEast = tCell.Font.Name  '日本語のフォント指定
            .Size = tCell.Font.Size         'フォントサイズ
            .Bold = msoTrue             '太字指定
        End With
        s.TextFrame2.AutoSize = msoAutoSizeShapeToFitText 'TextFrameのAutoSizeとは少し違い
        '横幅は変化しないで高さだけが調整される＋少し高さが高くなる
        
        
    '本文(テキストボックス)作成
        Set tCell = r.Cells(i, 2)
        Set tb = ASh.Shapes.AddTextbox(msoTextOrientationHorizontal, _
            s.Left, s.Top + s.Height, s.Width, s.Height)
        ssName(1) = tb.Name '名前を配列に入れる
        
        With tb
            .Line.ForeColor = s.Line.ForeColor
            .Height = 90
'            .Select False
            'Falseを指定すると前回Selectしたもの(タイトル部分の図形)が解除されない
            'つまりCtrl＋クリックした時と同じ効果
        End With
        
        With tb.TextFrame
            .Characters.text = tCell.Value
            mozisuu = .Characters.Count
        End With
        
        With tb.TextFrame2.TextRange.Characters(1, mozisuu).Font
            .Name = tCell.Font.Name         'フォント指定
            .NameFarEast = tCell.Font.Name  '日本語のフォント指定
            .Size = tCell.Font.Size
        End With
        
        '横幅そのままで高さだけピッタリに変更
        tb.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
'        tb.TextFrame.AutoSize = True'こっちだと横幅が変化してしまう

'図形のグループ化はSelectionを使ったほうがいいのか、配列を使ったほうがいいのか
'        Selection.Group 'Selectionを使って図形のグループ化
        ASh.Shapes.Range(ssName).Group.Select '名前を使ってタイトルと本文をグループ化
       '名前を使ってタイトルと本文をグループ化して
        Set gp = ASh.Shapes.Range(ssName).Group
        gp.Placement = xlFreeFloating   'セルに合わせて移動やサイズを変更しないに設定
        gp.Line.Weight = 0.1            '枠の太さ
    Next
End Sub