「excelからDDLを作成するマクロ例」の編集履歴（バックアップ）一覧はこちら

「excelからDDLを作成するマクロ例」(2014/08/18 (月) 18:55:56) の最新版変更点

追加された行は緑色になります。

削除された行は赤色になります。

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