excelからDDLを作成するマクロ例 - c0metssd @ ウィキ

V2：テーブル名
V1：テーブル名コメント
C5からフィールド
C5：カラムコメント
J5：物理名
R5：データ型
U5：長さ
W5：PK
X5：NN
Y5：UQ
Z5：FK

Option Explicit

Const ownerName = "postgres"

Function CreateTable(saveName)
    Dim Str As String
    Str = ""
    Dim tableName As String
    tableName = Range("V2").Value
    Dim fields As String
    fields = ""
    Dim alters As String
    alters = ""
    Dim lineNo As Integer: lineNo = 6
    Dim pkey: pkey = ""
    Do
        Dim nn As String
        If StrComp("○", Range("X" & lineNo).Value) = 0 Then
            nn = " NOT NULL"
        ElseIf StrComp("", Range("X" & lineNo).Value) <> 0 Then
            MsgBox "セル(X" & lineNo & ")に想定外の文字が指定されています：" & Range("X" & lineNo).Value
            Exit Function
        Else
            nn = ""
        End If
        
        Dim dtype As String
        Dim tVal As String
        tVal = Range("R" & lineNo).Value
        If StrComp("varchar(n)", tVal) = 0 Then
            Dim dlen As String: dlen = Range("U" & lineNo).Value
            If dlen = "" Then
                MsgBox "varchar(n)に長さが指定されていません"
                Exit Function
            End If
            dtype = "character varying(" & dlen & ")"
        ElseIf StrComp("serial", tVal) = 0 Then
            dtype = tVal
        ElseIf StrComp("boolean", tVal) = 0 Then
            dtype = tVal
        ElseIf StrComp("int", tVal) = 0 Then
            dtype = "integer"
        ElseIf StrComp("timestamp", tVal) = 0 Then
            dtype = "timestamp with time zone"
        ElseIf StrComp("smallint", tVal) = 0 Then
            dtype = tVal
        ElseIf StrComp("time", tVal) = 0 Then
            dtype = "time with time zone"
        ElseIf StrComp("date", tVal) = 0 Then
            dtype = tVal
        ElseIf StrComp("text", tVal) = 0 Then
            dtype = tVal
        ElseIf StrComp("bytea", tVal) = 0 Then
            dtype = tVal
        Else
            MsgBox "Unknown Data Type:" & tVal
            Exit Function
        End If
        
        If Len(fields) <> 0 Then
            fields = fields & ","
        End If
        
        Dim ColumnName As String: ColumnName = Range("J" & lineNo).Value
        fields = fields & " " & ColumnName & " " & dtype & nn & vbNewLine
        
        ' Primary Key
        If StrComp("○", Range("W" & lineNo).Value) = 0 Then
            If Len(pkey) <> 0 Then
                pkey = pkey & ","
            End If
            pkey = pkey & ColumnName
        ElseIf StrComp("", Range("W" & lineNo).Value) <> 0 Then
            MsgBox "セル(W" & lineNo & ")に想定外の文字が指定されています：" & Range("W" & lineNo).Value
            Exit Function
        End If
    
        ' Unique
        If StrComp("○", Range("Y" & lineNo).Value) = 0 Then
            alters = alters & "ALTER TABLE ONLY " & tableName & " ADD CONSTRAINT m_" & tableName & "_" & ColumnName & "_uq UNIQUE (" & ColumnName & ");" & vbNewLine
        ElseIf StrComp("", Range("Y" & lineNo).Value) <> 0 Then
            MsgBox "セル(Y" & lineNo & ")に想定外の文字が指定されています：" & Range("Y" & lineNo).Value
            Exit Function
        End If
    
        Dim fkWork: fkWork = Range("Z" & lineNo).Value
        fkWork = Replace(fkWork, vbTab, "")
        If fkWork <> "" Then
            Dim arr As Variant
            arr = Split(fkWork, ".")
            If UBound(arr) < 1 Then
                MsgBox "FKの指定が間違えています:" & Range("Z" & lineNo).Value
                Exit Function
            End If
            Dim colName: colName = Application.WorksheetFunction.VLookup(arr(1), Sheets(arr(0)).Range("C6:Z30"), 8, False)
            Dim tblName: tblName = Sheets(arr(0)).Range("V2").Value
            
            ' FKの設定
            alters = alters & "ALTER TABLE ONLY " & tableName & " ADD CONSTRAINT fk_" & tableName & "_" & ColumnName & " FOREIGN KEY (" & ColumnName & ") REFERENCES " & tblName & "(" & colName & ");" & vbNewLine
   
        End If
    
        ' カラムのコメント
        alters = alters & "COMMENT ON COLUMN " & tableName & "." & ColumnName & " IS '" & Range("C" & lineNo).Value & "';" & vbNewLine

        lineNo = lineNo + 1
    Loop While Range("C" & lineNo).Value <> ""
    
    ' テーブルのコメント
    If Len(pkey) <> 0 Then
        alters = alters & "ALTER TABLE ONLY " & tableName & " ADD CONSTRAINT m_" & tableName & "_pkey PRIMARY KEY (" & pkey & ");" & vbNewLine
    End If
    alters = alters & "COMMENT ON TABLE " & tableName & " IS '" & Range("V1").Value & "';" & vbNewLine
    alters = alters & "ALTER TABLE public." & tableName & " OWNER TO " & ownerName & ";" & vbNewLine
    
    ' くっつける
    Str = Str & "--- テーブル「" & tableName & "」" & vbNewLine
    Str = Str & "CREATE TABLE " & tableName & " (" & vbNewLine
    Str = Str & fields
    Str = Str & ");" & vbNewLine
    Str = Str & alters & vbNewLine
    '戻す
    CreateTable = Str
End Function

Function SetSaveDir()
    '*** 保存するパスの設定
    Dim myPath As String            'フォルダパス
    Dim ShellApp As Object
    Dim oFolder As Object
    Set ShellApp = CreateObject("Shell.Application")
    Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1)
    If oFolder Is Nothing Then Exit Function
    On Error Resume Next
        myPath = oFolder.Items.Item.Path
        If Err.Number = 91 Then
            'デスクトップが選択された場合は、直接取得する
            myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
            Err.Clear
        End If
        If Dir(myPath, vbDirectory) = "" Then
            MsgBox "保存するフォルダがありません。保存フォルダ： " & myPath
            Exit Function
        End If
    On Error GoTo 0
    SetSaveDir = myPath
End Function

Sub FileWrite(saveName, data)
    Const adTypeText = 2            '出力するためのConst
    Const adSaveCreateOverWrite = 2 '出力するためのConst
    Const adWriteLine = 1
    
    Dim mySrm As Object
    Set mySrm = CreateObject("ADODB.Stream")
    With mySrm
        '*** UTF-8で出力するためのADOを読み込み　start
        .Open
        .Type = adTypeText
        .Charset = "UTF-8"
        '*** UTF-8で出力するためのADOを読み込み　End
        
        'オブジェクトの内容をファイルに保存
        .WriteText data, adWriteLine
        .SaveToFile (saveName), adSaveCreateOverWrite
           
        'オブジェクトを閉じる
        .Close
    End With
    
    'メモリからオブジェクトを削除する
    Set mySrm = Nothing

End Sub

Private Sub DDL作成_Click()
    Dim saveName
    Dim saveDir
    saveDir = SetSaveDir()
    If Len(saveDir) = 0 Then
        Exit Sub
    End If
    saveName = saveDir & "\hoge.sql"
    
    Dim sqlStr As String
    sqlStr = ""
    Sheets("テーブル一覧").Select
    ' 描画停止
    Application.ScreenUpdating = False
    Do
        ActiveSheet.Next.Activate
        sqlStr = sqlStr & CreateTable(saveName)
    Loop While ActiveSheet.Name <> Sheets(Sheets.Count).Name ' 最後のシートまで
    
    'ファイルに出力する
    Call FileWrite(saveName, sqlStr)
    ' 描画開始
    Application.ScreenUpdating = True
    MsgBox "処理が終了しました"
End Sub

2014/8/15