[その他]SQLServerとExcelマクロを使ってリバースER図を作成する。（エンティティのみ）

①まずは以下のSQL文を↓SQLServer上指定のDB上にて実行しましょう

SELECT
object_name(sys.columns.object_id),
sys.columns.column_id,
sys.columns.name,
sys.indexes.name AS INDEX_NAME,
sys.indexes.is_primary_key AS TEST

FROM
sys.columns inner join sys.objects on
sys.columns.object_id = sys.objects.object_id


LEFT JOIN
sys.index_columns
on sys.columns.column_id = sys.index_columns.column_id
and sys.columns.object_id = sys.index_columns.object_id

LEFT JOIN sys.indexes
on sys.indexes.object_id = sys.index_columns.object_id

where

ISNULL(sys.indexes.is_primary_key ,-1) IN (-1,1)
and
sys.objects.type = 'U'

--もしER図に出したくないカラムがある場合はここで指定

--and
--sys.columns.name NOT IN ( --'created',
--'テスト項目',
--'削除フラグ'
--)

--テーブルしぼるならここで！

--and
--LEFT(object_name(sys.columns.object_id),8) IN (
--'T_氏名'
--'T_給与'
--)


order by
object_name(sys.columns.object_id),
column_id

②出力された結果をエクセルに貼り付けて以下の様にします
　（必ずＡ１セルから貼り付けてください）

③貼り付けたシート上で以下のＶＢＡマクロを実行します。

Dim WB As Workbook
Set WB = ActiveWorkbook
Dim WS1 As Worksheet
Set WS1 = WB.ActiveSheet

WS1.Select
Range("A1:E1").Select
Range(Selection, Selection.End(xlDown)).Select

'--------------------------------------------------------
'実行速度向上のため画面更新と自動計算を停止
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 intStartClm As Integer: intStartClm = Selection.Column
Dim intLastClm As Integer: intLastClm = Selection.Column + Selection.Columns.Count - 1

'※初期置
Dim Rng As Range
Set Rng = WS1.Cells(intStartGyo, intStartClm)


Dim lWidth As Long: lWidth = 150 'エンティティオブジェクトのサイズ
Dim lHeight As Long: lHeight = 14 'エンティティオブジェクトのサイズ

lLeft = Rng.Left + 350 '初期位置
Ltop = Rng.Top + 10 '初期位置

Dim TblCnt As Integer: TblCnt = 0
Dim TblTitle As String
Dim TblStartTop As Integer
Dim ECnt As Integer
Dim strShapes As String
Dim FlgKey As Boolean

For j = intStartGyo To intLastGyo

'テーブルカウント
If TblTitle <> WS1.Cells(j, intStartClm).Text Then
TblCnt = TblCnt + 1
TblTitle = WS1.Cells(j, intStartClm).Text
ECnt = 0
strShapes = ""
Ltop = WS1.Cells(j + 1, intStartClm).Top + 10
TblStartTop = Ltop
FlgKey = True
End If

'エンティティの作成---------------------------------------

Dim myShape1 As Shape

'主キーからそうでなくなった場合、線を足す
If WS1.Cells(j, intStartClm + 4).Text <> "1" Then
If FlgKey = True Then
Dim SShape As Shape
Set SShape = WS1.Shapes.AddConnector(msoConnectorStraight, lLeft, Ltop, lLeft + lWidth, Ltop)
strShapes = strShapes & "," & SShape.Name
FlgKey = False
End If
End If


Dim oShape As Shape
Set oShape = WS1.Shapes.AddShape(msoShapeRectangle, lLeft, Ltop, lWidth, lHeight)
With oShape
.Fill.Visible = msoFalse
.Fill.Solid 'グラデーション等無し
.Line.Visible = msoFalse
.TextFrame.Characters.Font.Color = vbBlack
If WS1.Cells(j, intStartClm + 4).Text <> "1" Then
.TextFrame.Characters.Text = WS1.Cells(j, intStartClm + 2).Text
Else
.TextFrame.Characters.Text = "■" & WS1.Cells(j, intStartClm + 2).Text
End If
.TextFrame.Characters.Font.Size = 8
.TextFrame.HorizontalAlignment = xlHAlignLeft
End With
strShapes = strShapes & "," & oShape.Name


'追加位置を下へずらす
Ltop = Ltop + lHeight
ECnt = ECnt + 1
'-------------------------------------------------------

'次が異なるテーブルor終了行---------------------------------
If Len(strShapes) > 0 Then
If WS1.Cells(j + 1, intStartClm).Text <> TblTitle Or j + 1 > intLastGyo Then


Set oShape = WS1.Shapes.AddShape(msoShapeRectangle, lLeft, TblStartTop - 20, lWidth, 30 + ECnt * (lHeight + 1))
With oShape
.Fill.Visible = msoFalse
.Fill.Solid 'グラデーション等無し
.Line.Visible = msoTrue
.TextFrame.Characters.Font.Color = vbBlue
.TextFrame.Characters.Text = TblTitle
.TextFrame.Characters.Font.Size = 8
.TextFrame.HorizontalAlignment = xlHAlignLeft
End With
'strShapes(ECnt) = oShape.Name
'ActiveSheet.Shapes.Range(Array("""" & oShape.Name & """" & strShapes)).Select
strShapes = strShapes & "," & oShape.Name


Dim valShapes() As String
valShapes = Split(strShapes, ",")


'oShape.Select
'Selection.ShapeRange.Group.Select
WS1.Shapes.Range(valShapes).Group

'追加位置を右へずらす
'lLeft = lLeft + lWidth + 5
'追加位置を下へずらす
Ltop = Ltop + 30 + ECnt * (lHeight + 1) + 10

End If
End If
'------------------------------------------------------------

Next

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

MsgBox ("作成成功")



End Sub

④以下の様にER図用のエンティティ図形が出来ます。