Excel VBA SQL文生成コード　自分用メモ  crossfish21

Module1

```
Option Explicit

Sub Main_dataOutput()

    Dim outputFilePath As String
    Dim i As Long
    Dim j As Long

    If Cells(2, 16).Value = "" Then
        MsgBox "出力用ファイルが指定されていません"
        End
    End If
    
    If Dir(Cells(2, 16).Value) <> "" Then
        outputFilePath = Cells(2, 16).Value
    Else
        MsgBox "指定された出力用ファイルは存在しません"
        End
    End If
    
    If (Cells(2, 3).Value) = "" Then
        MsgBox "テーブル名が空白です"
        End
    End If

    If (Cells(4, 3).Value) = "" Then
        MsgBox "カラム名の入力がありません"
        End
    End If

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim tableName As String
    Dim blankValue As String
    Dim lastColumnNumber As Long
    Dim lastRowNumber As Long
    Dim columnNameArray() As String
    Dim sqlStringArray() As String
    Dim sqlString As String
    Dim valueString As String  ' データの値
    
    Erase columnNameArray
    Erase sqlStringArray
    sqlString = ""
    tableName = Cells(2, 3).Value
    blankValue = Cells(2, 10).Value
    
    If ActiveSheet.CheckLastRow.Value = True Then
        lastRowNumber = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row
    Else
        lastRowNumber = Cells(ActiveSheet.Rows.Count, 3).End(xlUp).Row
    End If
    
    lastColumnNumber = Cells(4, ActiveSheet.Columns.Count).End(xlToLeft).Column

    
    
    For i = 3 To lastColumnNumber
        ReDim Preserve columnNameArray(i - 3)
        columnNameArray(i - 3) = Cells(4, i).Value
    Next i
    
    sqlString = "INSERT INTO " & tableName & " ("
    For i = 0 To UBound(columnNameArray)
        sqlString = sqlString & columnNameArray(i) & ","
    Next i
    sqlString = Mid(sqlString, 1, (Len(sqlString) - 1))  ' 最後の","は削除
    sqlString = sqlString & ") VALUES"
    
    ReDim sqlStringArray(0)
    sqlStringArray(0) = sqlString
    sqlString = ""
    
    
    For i = 5 To lastRowNumber
    
        sqlString = "("
        
        For j = 3 To lastColumnNumber
        
            valueString = Cells(i, j).Value ' データ部のセルの値
            valueString = EscapeSpecialChar(valueString)  ' エスケープ処理する
            
            If valueString = "" Then  ' セルの値が空白の場合
                If blankValue = "null" Then  ' 空白セルの代替文字列がnull指定の場合
                    sqlString = sqlString & "null,"
                Else
                    sqlString = sqlString & "'" & blankValue & "',"
                End If
                
            Else  ' セルの値がある場合
                sqlString = sqlString & "'" & valueString & "',"
            End If
        
        Next j
        
        sqlString = Mid(sqlString, 1, (Len(sqlString) - 1))  ' 最後の","は削除
        sqlString = sqlString & "),"
        
        ReDim Preserve sqlStringArray(i - 4)
        sqlStringArray(i - 4) = sqlString
        
    Next i
    
    sqlString = sqlStringArray(UBound(sqlStringArray))
    sqlString = Mid(sqlString, 1, (Len(sqlString) - 1))  ' 最後の","は削除
    sqlString = sqlString & ";"   ' ";"を追加
    sqlStringArray(UBound(sqlStringArray)) = sqlString


    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        For i = 0 To UBound(sqlStringArray)
                .WriteText sqlStringArray(i), 1  ' 1行ずつ書込み。行末に改行を挿入する
        Next i
        .SaveToFile outputFilePath, 2  ' 同名ファイルが存在する場合は上書き
    
    End With
    
    
    Erase columnNameArray
    Erase sqlStringArray
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "完了"

End Sub



Function EscapeSpecialChar(escapeSTR As String) As String  ' 特殊文字をエスケープ処理する

    escapeSTR = Replace(escapeSTR, "&", "&amp;")
    escapeSTR = Replace(escapeSTR, "<", "&lt;")
    escapeSTR = Replace(escapeSTR, ">", "&gt;")
    escapeSTR = Replace(escapeSTR, Chr(34), "&quot;")
    escapeSTR = Replace(escapeSTR, "'", "&#39;")
    escapeSTR = Replace(escapeSTR, "\", "\\")

    EscapeSpecialChar = escapeSTR

End Function



Sub SelectOutputFile_dataOutput() ' 出力するテキストファイルを選択する

    Dim outputTextDialog As FileDialog

    Set outputTextDialog = Application.FileDialog(msoFileDialogOpen)
    With outputTextDialog
        With .Filters
            .Clear
            .Add "テキストファイル", "*.txt", 1   ' テキストファイルのみ対象
        End With
        If .Show = True Then
            If Right(.SelectedItems(1), 3) = "txt" Then
                Cells(2, 16).Value = .SelectedItems(1)
            Else
                MsgBox "テキストファイルを選んでください"
            End If
        Else 'キャンセルボタンがクリックされた
            MsgBox "キャンセルされました"
        End If
    End With

End Sub


Sub Clear_dataOutput()  ' カラム名・データ部の値をクリア

    Range(Cells(6, 2), Cells(ActiveSheet.Rows.Count, 2)).ClearContents
    Range(Cells(4, 3), Cells(ActiveSheet.Rows.Count, ActiveSheet.Columns.Count)).ClearContents

End Sub

```
---
Module2

```
Option Explicit

Sub Main_createTable()

    Dim xFSO As New FileSystemObject
    Dim outputFilePath As String
    Dim i As Long
    Dim j As Long

    If Cells(2, 3).Value = "" Then
        MsgBox "出力用ファイルが指定されていません"
        End
    End If
    
    If Dir(Cells(2, 3).Value) <> "" Then
        outputFilePath = Cells(2, 3).Value
    Else
        MsgBox "指定された出力用ファイルは存在しません"
        End
    End If
    
    If (Cells(4, 3).Value) = "" Then
        MsgBox "テーブル名が空白です"
        End
    End If

    If (Cells(40, 2).Value) = "" Then
        MsgBox "カラム名の入力がありません"
        End
    End If

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim tableName As String
    Dim sqlStringArray() As String
    Dim sqlString As String
    Dim fKeyColumnsString As String   ' 外部キーSQLで、対象カラム名の部分
    Dim valueString As String  ' データの値
    
    Erase sqlStringArray
    
    tableName = Cells(4, 3).Value   ' テーブル名

    ReDim Preserve sqlStringArray(0)
    sqlStringArray(0) = "CREATE TABLE `" & tableName & "` ("   ' SQLの1行目のコード
    
    ' カラム部のSQLコード作成
    For i = 40 To 139
    
        If Cells(i, 2).Value = "" Then  ' もうカラムの指定がない行まで来た場合
            Exit For
        End If
        
        sqlString = "`" & Cells(i, 2).Value & "` " & Cells(i, 3).Value
        
        If Cells(i, 4).Value <> "" Then   ' NOT NULL 有効
            sqlString = sqlString & " NOT NULL"
        End If
        
        If Cells(i, 5).Value <> "" Then   ' AUTO INCREMENT 有効
            sqlString = sqlString & " AUTO_INCREMENT"
        End If
        
        If Cells(i, 6).Value <> "" Then   ' UNIQUE 有効
            sqlString = sqlString & " UNIQUE"
        End If
        
        If Cells(i, 7).Value <> "" Then   ' DEFAULT値設定
            If LCase(Cells(i, 7).Value) = "null" Then  ' null設定の場合
                sqlString = sqlString & " DEFAULT NULL"
            Else
                sqlString = sqlString & " DEFAULT '" & Cells(i, 7).Value & "'"
            End If
        End If
        

        
        sqlString = sqlString & ","
        ReDim Preserve sqlStringArray(UBound(sqlStringArray) + 1)
        sqlStringArray(UBound(sqlStringArray)) = sqlString
        
    Next i
    
    
    ' INDEX部のSQLコード作成
    If ActiveSheet.indexCheck.Value = True Then
        For i = 10 To 16
        
            If Cells(i, 2).Value = "" Then  ' もうINDEXの指定がない行まで来た場合
                Exit For
            End If
            
            sqlString = "INDEX `" & Cells(i, 2).Value & "` (`" & Cells(i, 3).Value & "`"
            
            If Cells(i, 4).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 4).Value & "`"
            End If
            
            If Cells(i, 5).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 5).Value & "`"
            End If
        
            If Cells(i, 6).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 6).Value & "`"
            End If
            
            If Cells(i, 7).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 7).Value & "`"
            End If
            
            sqlString = sqlString & "),"
            ReDim Preserve sqlStringArray(UBound(sqlStringArray) + 1)
            sqlStringArray(UBound(sqlStringArray)) = sqlString
            
        Next i
    End If
    
    
    ' KEY部のSQLコード作成
    If ActiveSheet.keyCheck.Value = True Then
        For i = 20 To 26
        
            If Cells(i, 2).Value = "" Then  ' もうKEYの指定がない行まで来た場合
                Exit For
            End If
            
            sqlString = "KEY `" & Cells(i, 2).Value & "` (`" & Cells(i, 3).Value & "`"
            
            If Cells(i, 4).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 4).Value & "`"
            End If
            
            If Cells(i, 5).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 5).Value & "`"
            End If
        
            If Cells(i, 6).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 6).Value & "`"
            End If
            
            If Cells(i, 7).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 7).Value & "`"
            End If
            
            If Cells(i, 8).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 8).Value & "`"
            End If
            
            sqlString = sqlString & "),"
            ReDim Preserve sqlStringArray(UBound(sqlStringArray) + 1)
            sqlStringArray(UBound(sqlStringArray)) = sqlString
            
        Next i
    End If
    
      
    ' 外部KEY部のSQLコード作成
    If ActiveSheet.fKeyCheck.Value = True Then
        For i = 30 To 36
        
            If Cells(i, 2).Value = "" Then  ' もう外部KEYの指定がない行まで来た場合
                Exit For
            End If
            
            sqlString = "KEY `" & Cells(i, 2).Value & "_" & tableName & "` "
            ' 外部キー名は同DB内で重複が許可されないので、テーブル名を付与して重複を防ぐ
            
            fKeyColumnsString = "(`" & Cells(i, 3).Value & "`"
            
            If Cells(i, 4).Value <> "" Then
                fKeyColumnsString = fKeyColumnsString & ",`" & Cells(i, 4).Value & "`"
            End If
            
            If Cells(i, 5).Value <> "" Then
                fKeyColumnsString = fKeyColumnsString & ",`" & Cells(i, 5).Value & "`"
            End If
        
            If Cells(i, 6).Value <> "" Then
                fKeyColumnsString = fKeyColumnsString & ",`" & Cells(i, 6).Value & "`"
            End If
            
            If Cells(i, 7).Value <> "" Then
                fKeyColumnsString = fKeyColumnsString & ",`" & Cells(i, 7).Value & "`"
            End If
            
            fKeyColumnsString = fKeyColumnsString & ")"
            
            sqlString = sqlString & fKeyColumnsString & ","
            ReDim Preserve sqlStringArray(UBound(sqlStringArray) + 1)
            sqlStringArray(UBound(sqlStringArray)) = sqlString
            
            sqlString = "CONSTRAINT `" & Cells(i, 2).Value & "_" & tableName & "`"
            ReDim Preserve sqlStringArray(UBound(sqlStringArray) + 1)
            sqlStringArray(UBound(sqlStringArray)) = sqlString
            
            sqlString = "FOREIGN KEY " & fKeyColumnsString
            ReDim Preserve sqlStringArray(UBound(sqlStringArray) + 1)
            sqlStringArray(UBound(sqlStringArray)) = sqlString
            
            sqlString = "REFERENCES `" & Cells(i, 8).Value & "` (`" & Cells(i, 9).Value & "`"
            
            If Cells(i, 10).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 10).Value & "`"
            End If
            
            If Cells(i, 11).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 11).Value & "`"
            End If
            
            If Cells(i, 12).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 12).Value & "`"
            End If
            
            If Cells(i, 13).Value <> "" Then
                sqlString = sqlString & ",`" & Cells(i, 13).Value & "`"
            End If
            
            sqlString = sqlString & ")"
            ReDim Preserve sqlStringArray(UBound(sqlStringArray) + 1)
            sqlStringArray(UBound(sqlStringArray)) = sqlString
            
            sqlString = "ON DELETE CASCADE ON UPDATE CASCADE"
            ReDim Preserve sqlStringArray(UBound(sqlStringArray) + 1)
            sqlStringArray(UBound(sqlStringArray)) = sqlString & ","
            
        Next i
    End If
    
    
    ' PRIMARY KEY
    If ActiveSheet.primaryCheck.Value = True Then
        ReDim Preserve sqlStringArray(UBound(sqlStringArray) + 1)
        sqlStringArray(UBound(sqlStringArray)) = "PRIMARY KEY (`" & Cells(6, 3).Value & "`)"
    End If
    
    
    If Right(sqlStringArray(UBound(sqlStringArray)), 1) = "," Then  ' 最後の要素の末尾が","場合
        sqlString = sqlStringArray(UBound(sqlStringArray))
        sqlString = Mid(sqlString, 1, (Len(sqlString) - 1))  ' 最後の","は削除
        sqlStringArray(UBound(sqlStringArray)) = sqlString
    End If
    
    
    ReDim Preserve sqlStringArray(UBound(sqlStringArray) + 1)
    sqlStringArray(UBound(sqlStringArray)) = ") ENGINE=InnoDB DEFAULT CHARSET=utf8mb4;"
    
    
    
    Kill outputFilePath  ' 現ファイルは削除
    
    ' テキストファイルに書込みをする
    With xFSO.CreateTextFile(outputFilePath, True)
        For i = 0 To UBound(sqlStringArray)
                .WriteLine sqlStringArray(i)
        Next i
    End With
    
    
    Erase sqlStringArray
    Set xFSO = Nothing


    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "完了"


End Sub



Sub SelectOutputFile_createTable() ' 出力するテキストファイルを選択する

    Dim outputTextDialog As FileDialog

    Set outputTextDialog = Application.FileDialog(msoFileDialogOpen)
    With outputTextDialog
        With .Filters
            .Clear
            .Add "テキストファイル", "*.txt", 1   ' テキストファイルのみ対象
        End With
        If .Show = True Then
            If Right(.SelectedItems(1), 3) = "txt" Then
                Cells(2, 3).Value = .SelectedItems(1)
            Else
                MsgBox "テキストファイルを選んでください"
            End If
        Else 'キャンセルボタンがクリックされた
            MsgBox "キャンセルされました"
        End If
    End With

End Sub


Sub Clear_createTable()  ' カラム名・データ部の値をクリア

    Cells(4, 3).ClearContents
    Cells(6, 3).ClearContents
    Range(Cells(10, 2), Cells(16, 7)).ClearContents
    Range(Cells(20, 2), Cells(26, 7)).ClearContents
    Range(Cells(30, 2), Cells(36, 13)).ClearContents
    Range(Cells(40, 2), Cells(139, 7)).ClearContents

End Sub


```