複数行のセルの値をまとめて1つのテキストボックスにするマクロその2

前回の

gogowaten.hatenablog.com

複数行のセルの値をまとめて1つのテキストボックスにするマクロ ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
http://blogs.yahoo.co.jp/gogowaten/14674215.html

つづき

選択セル範囲の左の1列をまとめて1つのテキストボックスにする

行ごとのフォントとフォントサイズと

文字ごとの色に対応した

前回と違うのは

行ごとのフォントとフォントサイズに対応
文字ごとの色に対応
背景色は左上のセルと同じにするようにした、塗りつぶしなしやグラデーションの場合は白背景になる
テキストボックスのサイズとプロパティのオブジェクトの位置関係はセルに合わせて移動もサイズ変更もしないに変更した

今回のマクロ

AddTextBoxFromCellsValue3を実行するとテキストボックスを作成する

Sub AddTextBoxFromCellsValue3()
  '選択されているのがセル以外なら何もしないで終了
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    Dim myCells As Range: Set myCells = Selection
     '左端の一列
    Set myCells = myCells.Resize(myCells.Rows.Count, 1)
    Dim tlCell As Range
    Set tlCell = myCells.Cells(1) '左上のセル
    
     'テキストボックスに表示する文字列を作成
    Dim str As String: str = tlCell.text
    Dim i As Integer
    For i = 2 To myCells.Cells.Count
        str = str & vbNewLine & myCells.Cells(i).text
    Next
        
    'テキストボックス作成
    Dim myTB As Shape
    Set myTB = ActiveSheet.Shapes.AddTextbox( _
                msoTextOrientationHorizontal, _
                tlCell.Left, tlCell.Top, 100, 10)
    With myTB
        .TextFrame.AutoSize = True 'オートサイズを有効にする
'        .Placement = xlMove 'セルに合わせて移動するけどサイズ変更しない
       .Placement = xlFreeFloating '移動もサイズ変更もしない

        '背景色設定、左上のセルの色が単色ならその色にする
        If tlCell.Interior.ColorIndex <> xlColorIndexAutomatic And _
            tlCell.Interior.ColorIndex <> xlColorIndexNone Then
            .Fill.ForeColor.Rgb = tlCell.Interior.Color
        End If
        '文字の設定
        With .TextFrame2.TextRange
            .text = str '文字列指定
            For i = 1 To .Paragraphs.Count
                'フォントカラーの指定
                Call SetFontColor(.Paragraphs(i), myCells(i))
                'フォントの指定
                Call SetFontToParagraph(.Paragraphs(i), myCells(i))
            Next
        End With
    End With
End Sub

'Paragraphのフォントカラーをセルのフォントカラーに合わせる
Sub SetFontColor(p As TextRange2, r As Range)
    'セルのフォントカラーがNullなら複数の色が指定されているので
    '1文字ごとに色指定する
    If IsNull(r.Font.Color) Then
        For i = 1 To p.Characters.Count
            p.Characters(i, 1).Font.Fill.ForeColor.Rgb _
                = r.Characters(i, 1).Font.Color
        Next
    Else
        p.Font.Fill.ForeColor.Rgb = r.Font.Color
    End If
End Sub

'Paragraphのフォントをセルのフォントに合わせる
Sub SetFontToParagraph(p As TextRange2, r As Range)
    Dim f As Font: Set f = r.Font
    With p.Font
        .Name = f.Name
        .NameFarEast = f.Name
        .Size = f.Size
    End With
End Sub