TBL作成マクロ

Sub GenerateSQLScriptsFromFile_CreateTableWithPrimaryKey()
    ' このマクロはExcelのテーブル定義書からSQLスクリプトを生成します。
    ' 主キーはCREATE TABLE文内に含め、カラムにDEFAULT値を設定します。
    ' コメント、GRANT文、SYNONYM文も生成します。
    ' CREATE TABLEの前にDROP TABLEを追加します。

    Dim wb As Workbook ' ユーザーが選択したExcelブック
    Dim ws As Worksheet ' 処理対象のシート
    Dim lastRow As Long ' 処理対象シートの最終行
    Dim tableName As String ' テーブル物理名
    Dim columnName As String ' カラム物理名
    Dim dataType As String ' カラムのデータ型
    Dim length As String ' データ型の桁数
    Dim decimalScale As String ' データ型の少数桁数
    Dim defaultValue As String ' 初期値（DEFAULT句用）
    Dim notNull As String ' NOT NULL制約
    Dim primaryKey As String ' 主キーかどうか
    Dim primaryKeys As String ' 主キーのカラムリスト
    Dim description As String ' 項目説明（COMMENT句用）
    Dim dropTableScript As String ' DROP TABLE文
    Dim createTableScript As String ' CREATE TABLE文
    Dim commentTableScript As String ' テーブルコメントのSQL
    Dim commentColumnScript As String ' カラムコメントのSQL
    Dim grantScript As String ' GRANT文
    Dim synonymScript As String ' SYNONYM文
    Dim sqlScript As String ' 完成したSQLスクリプト全体
    Dim outputFilePath As String ' 出力ファイルの保存パス
    Dim excludedSheets As Variant ' 処理対象外のシート名リスト
    Dim i As Long ' カラム処理のループカウンター
    Dim filePath As String ' ユーザーが選択したファイルパス

    ' 処理対象外のシート名
    excludedSheets = Array("改訂履歴", "テーブル一覧", "シーケンス一覧", "XXXXXXX")

    ' ファイル選択ダイアログを表示
    filePath = Application.GetOpenFilename("Excel Files (*.xls; *.xlsx), *.xls; *.xlsx", , "テーブル定義書を選択してください")
    If filePath = "False" Then Exit Sub ' キャンセルされた場合は終了

    ' 選択されたExcelファイルを開く
    Set wb = Workbooks.Open(filePath)

    ' 出力ファイルの保存先を設定
    outputFilePath = ThisWorkbook.Path & "\Generated_Scripts.sql"

    ' UTF-8形式でスクリプトファイルを作成
    Dim fileStream As Object
    Set fileStream = CreateObject("ADODB.Stream")
    With fileStream
        .Type = 2 ' テキストデータとして扱う
        .Charset = "UTF-8" ' UTF-8形式で保存
        .Open
    End With

    ' 全シートを処理
    For Each ws In wb.Sheets
        If Not IsInArray(ws.Name, excludedSheets) Then
            lastRow = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row ' D列で最終行を取得
            tableName = ws.Range("D2").Value ' テーブル物理名
            
            ' DROP TABLE文の作成
            dropTableScript = "DROP TABLE " & tableName & ";" & vbCrLf

            ' CREATE TABLE文の開始部分を作成
            createTableScript = "CREATE TABLE " & tableName & " (" & vbCrLf
            commentTableScript = "COMMENT ON TABLE " & tableName & " IS '" & ws.Range("B3").Value & "';" & vbCrLf
            commentColumnScript = ""
            primaryKeys = "" ' 主キーの初期化

            ' 各行を処理
            For i = 5 To lastRow
                columnName = ws.Cells(i, 4).Value ' カラム名
                dataType = ws.Cells(i, 5).Value ' データ型
                length = Trim(ws.Cells(i, 6).Value) ' 桁数（F列）
                decimalScale = Trim(ws.Cells(i, 7).Value) ' 少数桁数（G列）
                defaultValue = Trim(ws.Cells(i, 17).Value) ' 初期値 (Q列)
                notNull = ws.Cells(i, 8).Value ' NOT NULL
                primaryKey = ws.Cells(i, 9).Value ' 主キー
                description = ws.Cells(i, 19).Value ' 項目説明（S列）

                ' データ型の組み立て
                If UCase(dataType) = "NUMBER" Then
                    ' NUMBER型の場合
                    If length = "" Or length = "-" Then
                        length = "10" ' デフォルト桁数
                    End If
                    dataType = "NUMBER(" & length & ",0)"
                Else
                    ' 他のデータ型
                    If length <> "" And length <> "-" Then
                        If decimalScale <> "" Then
                            dataType = dataType & "(" & length & ", " & decimalScale & ")"
                        Else
                            dataType = dataType & "(" & length & ")"
                        End If
                    End If
                End If

                ' DEFAULT値の設定
                If defaultValue <> "" Then
                    Select Case UCase(defaultValue)
                        Case "NULL", "null"
                            dataType = dataType & " DEFAULT NULL"
                        Case "△（スペース）"
                            dataType = dataType & " DEFAULT ''"
                        Case IsNumeric(defaultValue)
                            dataType = dataType & " DEFAULT '" & defaultValue & "'"
                        Case Else
                            ' defaultValueに"SYSTIMESTAMP"が含まれる場合はそのまま出力
                            If InStr(UCase(defaultValue), "SYSTIMESTAMP") > 0 Then
                                dataType = dataType & " DEFAULT " & defaultValue
                            Else
                                ' それ以外はシングルクォートで括る
                                dataType = dataType & " DEFAULT '" & defaultValue & "'"
                            End If
                    End Select
                End If

                ' NOT NULL制約を適用
                If notNull = "Y" Then
                    dataType = dataType & " NOT NULL"
                End If

                ' CREATE TABLE文にカラムを追加
                createTableScript = createTableScript & "    " & columnName & " " & dataType & "," & vbCrLf

                ' カラムコメントを追加
                If description <> "" Then
                    commentColumnScript = commentColumnScript & _
                        "COMMENT ON COLUMN " & tableName & "." & columnName & " IS '" & description & "';" & vbCrLf
                End If

                ' 主キーリストに追加
                If primaryKey = "Y" Then
                    If primaryKeys = "" Then
                        primaryKeys = columnName
                    Else
                        primaryKeys = primaryKeys & ", " & columnName
                    End If
                End If
            Next i

            ' 主キーをCREATE TABLE文に追加
            If primaryKeys <> "" Then
                createTableScript = createTableScript & "    PRIMARY KEY (" & primaryKeys & ")" & vbCrLf
            End If

            ' CREATE TABLE文を閉じる
            createTableScript = createTableScript & ");" & vbCrLf

            ' GRANT文とSYNONYM文を生成
            grantScript = "GRANT SELECT, UPDATE, INSERT ON " & tableName & " TO &1;" & vbCrLf
            synonymScript = "CREATE SYNONYM &2.." & tableName & vbCrLf & "FOR &1.." & tableName & ";" & vbCrLf

            ' SQLスクリプト全体を結合
            sqlScript = dropTableScript & createTableScript & commentTableScript & commentColumnScript & grantScript & synonymScript

            ' ファイルに書き込み
            fileStream.WriteText sqlScript & vbCrLf
        End If
    Next ws

    ' ファイルを保存して閉じる
    fileStream.SaveToFile outputFilePath, 2 ' 新規作成または上書き
    fileStream.Close
    wb.Close False ' Excelファイルを閉じる

    ' 完了メッセージ
    MsgBox "SQLスクリプトが生成されました: " & outputFilePath
End Sub

' 配列内に値が存在するか判定
Function IsInArray(val As Variant, arr As Variant) As Boolean
    Dim i As Long
    For i = LBound(arr) To UBound(arr)
        If val = arr(i) Then
            IsInArray = True
            Exit Function
        End If
    Next i
    IsInArray = False
End Function