[VBA]選択しているセルを図形オブジェクトに一発変換するマクロ

フローや機能要件を作成するときに
一度Excelのセルに打ったものを一気に図形オブジェクトに変換したい時用マクロ。


例）これを

　　　　　　　　　　↓

一発でこんな感じに。

----------------------------------------------------------------
Private Sub MakeObject()


    Dim WB As Workbook
    Set WB = ThisWorkbook
    Dim WS1 As Worksheet
    Set WS1 = WB.ActiveSheet
 
    '--------------------------------------------------------
    '実行速度向上のため画面更新と自動計算を停止
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    '-----------------------------------------------------------

    '現在選択しているセルの取得
    Dim intStartGyo As Integer: intStartGyo = Selection.Row
    Dim intLastGyo As Integer: intLastGyo = Selection.Row + Selection.Rows.Count - 1
    Dim intStartRow As Integer: intStartRow = Selection.Column
    Dim intLastRow As Integer: intLastRow = Selection.Column + Selection.Columns.Count - 1
 
    '※初期置
    Dim Rng As Range
    Set Rng = WS1.Cells(intStartGyo, intStartRow)
 
    Dim lWidth As Long: lWidth = 100  'オブジェクトのサイズ
    Dim lHeight  As Long: lHeight = 20  'オブジェクトのサイズ

 
    lLeft = Rng.Left + 10
    For i = intStartGyo To intLastGyo
   
        lTop = Rng.Top
        For j = intStartRow To intLastRow
         
            'If Len(WS1.cells(i, j).Text) > 0 And WS1.cells(i, j).Text > 0 Then '空欄なら作らない
                       
              '図形の作成---------------------------------------
              Dim myShape1 As Shape
              Dim strText As String
              strText = WS1.Cells(i, j).Text
              Set myShape1 = WS1.Shapes.AddShape( _
                    Type:=msoShapeRectangle, _
                    Left:=lLeft, _
                    Top:=lTop, _
                    Width:=lWidth, _
                    Height:=lHeight)
                With myShape1
                    .Fill.Visible = msoTrue
                    .Fill.Solid
                    .TextFrame.Characters.Text = strText
                    .TextFrame.HorizontalAlignment = xlCenter
                End With
              '-------------------------------------------------------
         
              '追加位置を下へずらす
              lTop = lTop + lHeight + 5
           
            'End If
     
            Next

       '追加位置を右へずらす

       lLeft = lLeft + lWidth + 5
 
    Next

    '実行速度向上のため画面更新と自動計算を再開---------------
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    '-----------------------------------------------------------


End Sub