Excelのセル内のテキストをもとにShapeを作り、グループ化するマクロ

Excelで作成したDBのテーブル定義書などをもとにER図をExcelのShapeを使って作成するのを補助するマクロです。 カラム名を選択した状態でこのマクロを実行すると、各セル単位でShapeを作成し、グループ化します。 ER図作成時にコネクタを任意のカラムに結合したのに、レイアウトの都合からShapeを移動するとコネクタの位置がずれるので作成しました。

Sub CellTextToShape()
'
' ER図作成補助 Macro
' 選択された範囲の文字列をテキストとするShapeを作成する
'
' Keyboard Shortcut: Ctrl+q
'
    Set xColumns = New Collection

    '外枠
    px = Selection.Left - 5
    py = Selection.Top - 5
    pw = Selection(1).Width + 10
    ph = Selection(1).Height * Selection.Count + 10
    Dim xParent As Shape
    Set xParent = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=px, Top:=py, Width:=pw, Height:=ph)
    xParent.Line.ForeColor.RGB = RGB(0, 0, 0)
    xParent.Fill.ForeColor.RGB = RGB(255, 255, 255)
    xColumns.Add xParent
    
    '中身
    For i = Selection(1).Row To Selection(Selection.Count).Row
        nCol = Selection(1).Column
        nRow = Selection(1).Row
        x = Cells(i, nCol).Left
        y = Cells(i, nCol).Top
        w = Cells(i, nCol).Width
        h = Cells(i, nCol).Height
        txt = Cells(i, nCol).Value
        s = Cells(i, nCol).Font.Size
        Dim xShape As Shape
        Set xShape = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=x, Top:=y, Width:=w, Height:=h)
        xShape.TextFrame.Characters.Text = txt
        xShape.TextFrame.Characters.Font.Color = vbBlack
        xShape.TextFrame.Characters.Font.Size = s
        xShape.TextFrame.HorizontalAlignment = xlHAlignLeft
        xShape.TextFrame.MarginBottom = 0
        xShape.TextFrame.MarginTop = 0
        xShape.Fill.Visible = False
        xShape.Line.Visible = False
        xShape.Name = txt

        xColumns.Add xShape
        
        Debug.Print (txt & vbTab & w & vbTab & h)
        'ActiveSheet.Shapes(txt).TextFrame.Characters.Text = txt
    Next
    
    For Each xShape In xColumns
        xShape.Select Replace:=False
    Next
    Selection.Group
    
End Sub