takayukisの日記 このページをアンテナに追加 RSSフィード

2018.10.23(火)

[]選択範囲のテキストをシェイプにする

数年前のメモから。TextFrame2を使っているので、怪しい。

Sub 選択範囲のテキストをシェイプにする()
    Dim 選択セル As Range
    Set 選択セル = Selection
    Dim セル As Range
    Dim シェイプ As Shape
    For Each セル In 選択セル
        If セル.text <> "" Then
             Set シェイプ = シェイプ追加(セル)
             シェイプ.Select (False)
        End If
    Next セル
End Sub

Function シェイプ追加(セル As Range) As Shape
    Dim シート As Worksheet
    Set シート = ActiveSheet
    Dim シェイプ As Shape
    Set シェイプ = シート.Shapes.AddShape(msoShapeRectangle, 292.5, 134.25, 95.25, 73.5)
    
    Dim 選択セル As Range
    Set 選択セル = セル
    シェイプ.Top = 選択セル.Top
    シェイプ.Left = 選択セル.Left
    
    Dim テキストフレーム As TextFrame2
    Set テキストフレーム = シェイプ.TextFrame2
    テキストフレーム.WordWrap = msoFalse
    テキストフレーム.AutoSize = msoAutoSizeShapeToFitText
    テキストフレーム.TextRange.text = セル.text

    Set シェイプ追加 = シェイプ
End Function

追記

別のバージョンがあった。

Sub 選択範囲の値でシェイプを作る()
    Dim シェイプ As Shape
    Dim 選択範囲 As Range
    Dim セル As Range
    Set 選択範囲 = Selection
    For Each セル In 選択範囲
        Set シェイプ = ActiveSheet.shapes.AddShape(msoShapeRectangle, セル.Left, セル.Top, 80, 30)
        シェイプ.TextFrame.Characters.text = セル.Value
        シェイプ.TextFrame.AutoSize = True
    Next
End Sub 

はてなユーザーのみコメントできます。はてなへログインもしくは新規登録をおこなってください。

トラックバック - http://d.hatena.ne.jp/takayukis/20181023/1540250034