VBA

VBA スクリプト出力(FileSystemObject)

More than 1 year has passed since last update.

スクリプト生成 a-sato

仕様 指定した分のテーブルのデータ投入SQL文を生成(FileSystemObject)

仕様 文字コードは考慮していない

createScript
Option Explicit

'/* sqlファイルパス */
'Const sqlFilePath As String = ThisWorkbook.Path & "\sql"
'------------------------------------------------------------------------------
'機能     :シート毎のデータ投入スクリプトを作成する(main)
'引数     :なし
'戻り値    :なし
'例外     :なし
'------------------------------------------------------------------------------
Sub createScript()

    Dim sqlFilePath As String

    sqlFilePath = ThisWorkbook.Path & "\sql"

    '/* FreeFile値 */
    Dim fileNo As Integer

    '/* ファイル名配列(=シート名) */
    Dim fileName()  As String

    Dim i As Long
    Dim j As Integer
    Dim buff As String
    Dim buffDelete As String
    Dim buffHeader As String
    Dim buffData   As String

    '-----------------------------
    'スクリプト格納フォルダ作成
    '-----------------------------
    createScriptDir

    '-----------------------------
    'シート名(ファイル名)を設定
    '-----------------------------
    Call createFileName(fileName)

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    With fso.createTextFile(sqlFilePath & "\" & "createData.sql")
        '-----------------------------
        'scriptファイル出力
        '-----------------------------
        '出力するテーブルを指定する場合
        For i = 0 To UBound(fileName)


            Sheets("" & fileName(i) & "").Activate

            '----- タイトルコメント出力 -----
            buff = ""
            buff = createTitle(fileName(i))

            '----- delete スクリプト出力 -----
            buffDelete = buff & vbCrLf & "DELETE FROM " & fileName(i) & ";"
            .Write buffDelete
            .Write vbCrLf

            '----- insert 先頭行スクリプト出力 -----
            buffHeader = ""
            buffHeader = createHeader(fileName(i))

            '----- 行毎のデータスクリプト出力 -----
            buffData = createBody(fileName(i), buffHeader)
            .Write buffData

        Next i
        .Close
    End With
    Set fso = Nothing


    MsgBox ("完了")

End Sub
'------------------------------------------------------------------------------
'機能     :スクリプト格納用フォルダを作成する
'引数     :なし
'戻り値    :なし
'例外     :なし
'------------------------------------------------------------------------------
Sub createScriptDir()

    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")

    '-----------------------------
    'ディレクトリがあれば削除
    '-----------------------------
    If fso.FolderExists(ThisWorkbook.Path & "\sql") Then
        fso.DeleteFolder ThisWorkbook.Path & "\sql"
    End If

    Set fso = Nothing

    '-----------------------------
    'ディレクトリの作成
    '-----------------------------
    MkDir (ThisWorkbook.Path & "\sql")


End Sub
'------------------------------------------------------------------------------
'機能     :ワークシート名からファイル名配列を作成する
'引数     :ファイル名配列
'戻り値    :ファイル名配列
'例外     :なし
'------------------------------------------------------------------------------
Function createFileName(ByRef fileName() As String) As String()
    Dim i As Long
    Dim maxRow As Long

    'シートで出力テーブルを指定して作成する場合
    With Sheets("テーブルリスト")
        maxRow = getMaxRow

        For i = 2 To maxRow
            ReDim Preserve fileName(i - 2)
            fileName(i - 2) = Cells(i, 2)
        Next i

    End With



'全シート分作成する場合
'    For i = 1 To ThisWorkbook.Sheets.Count
'        ReDim Preserve fileName(i - 1)
'        fileName(i - 1) = Sheets(i).Name
'    Next i

    createFileName = fileName

End Function
'------------------------------------------------------------------------------
'機能     :batファイルを作成する
'引数     :なし
'戻り値    :なし
'例外     :なし
'------------------------------------------------------------------------------
Sub createBatFile()

    Dim fileNo As Integer

    fileNo = FreeFile

    Open batFilePath & "\create.bat" For Output As #fileNo

    Print #fileNo, "cd ..\sql"
    Print #fileNo, "sqlplus /nolog @create_tablesList.sql > ..\log\exec.log"
    Print #fileNo, "pause"

    Close #fileNo

End Sub
'------------------------------------------------------------------------------
'機能     :SQL実行リストファイルを作成する
'引数     :ファイル名配列
'戻り値    :なし
'例外     :なし
'------------------------------------------------------------------------------
Sub createSQLListFile(ByRef fileName() As String)

    Dim fileNo As Integer

    fileNo = FreeFile

    Open sqlFilePath & "\create_tablesList.sql" For Output As #fileNo

    Print #fileNo, "CONNECT TEST1/a;"

    For i = 1 To UBound(fileName)
        Print #fileNo, "@" & Format$(i, "000") & "_" & fileName(i) & ".sql"
    Next i

    Print #fileNo, "EXIT"

    Close #fileNo

End Sub
'------------------------------------------------------------------------------
'機能     :項目の最終列を返却する
'引数     :なし
'戻り値    :項目の最終行
'例外     :なし
'------------------------------------------------------------------------------
Function getMaxCol() As Long
    getMaxCol = Range("A1").End(xlToRight).column
End Function
'------------------------------------------------------------------------------
'機能     :項目の最終行を返却する
'引数     :なし
'戻り値    :項目の最終行
'例外     :なし
'------------------------------------------------------------------------------
Function getMaxRow() As Long
    getMaxRow = Range("A1").End(xlDown).Row
End Function

'------------------------------------------------------------------------------
'機能     :タイトル部のスクリプト文字列を生成する
'引数     :ファイル名(シート名)
'戻り値    :タイトル部のスクリプト文字列
'例外     :なし
'------------------------------------------------------------------------------
Function createTitle(ByVal sheetName As String) As String

    '/* 出力文字列 */
    Dim buff  As String

    buff = ""
    buff = buff & vbCrLf & "-------------------------------"
    buff = buff & vbCrLf & "-- " & sheetName
    buff = buff & vbCrLf & "-------------------------------"

    createTitle = buff
End Function
'------------------------------------------------------------------------------
'機能     :Header(カラム部)のスクリプト文字列を生成する
'引数     :ファイル名(シート名)
'引数     :初期化(削除)までのスクリプト文字列
'戻り値    :Header部のスクリプト文字列
'例外     :なし
'------------------------------------------------------------------------------
Function createHeader(ByVal sheetName As String) As String

    '/* 出力文字列 */
    Dim i           As Long
    Dim maxCol      As Integer
    Dim buffHeader  As String

    With Sheets("" & sheetName & "")

        maxCol = getMaxCol

        buffHeader = "INSERT INTO " & sheetName & " ("

        'ヘッダスクリプト出力
        For i = 1 To getMaxCol
            buffHeader = buffHeader & .Cells(1, i) & ","
        Next i

        '最後の項目の","を除去
        buffHeader = Left$(buffHeader, Len(buffHeader) - 1)
        buffHeader = buffHeader & ") values "

    End With


    createHeader = buffHeader
End Function
'------------------------------------------------------------------------------
'機能     :Body(データ部)のスクリプト文字列を生成する
'引数     :ファイル名(シート名)
'引数     :ヘッダまでのスクリプト文字列
'戻り値    :CREATE TABLEのDDL文字列
'例外     :なし
'------------------------------------------------------------------------------
Function createBody(ByVal sheetName As String, buffHeader As String) As String

    '/* 出力文字列 */
    Dim i As Long
    Dim j As Integer
    Dim maxRow As Long
    Dim maxCol As Integer
    Dim attr As String
    Dim buff As String

    With Sheets("" & sheetName & "")

        maxRow = getMaxRow
        maxCol = getMaxCol


        buff = ""

        '全行分のスクリプト生成
        For i = 4 To maxRow
            buff = buff & buffHeader & "("

            '全列分のスクリプト生成
            For j = 1 To maxCol
                attr = .Cells(3, j)

                '属性によって出力するSQL文を切り替える
                Select Case attr
                    Case "NUMBER"
                        buff = buff & .Cells(i, j) & ","
                    Case Else
                        buff = buff & "'" & .Cells(i, j) & "',"
                End Select
            Next j

            buff = Left$(buff, Len(buff) - 1)
            buff = buff & ");" & vbCrLf

        Next i

    End With


    createBody = buff
End Function
'------------------------------------------------------------------------------
'機能     :シートを作成する
'引数     :なし
'引数     :なし
'戻り値    :なし
'例外     :なし
'------------------------------------------------------------------------------
Sub createSheet()
    Dim i As Long

   With Application
        .ScreenUpdating = False

    For i = 2 To Cells(2, 4)
        Sheets(2).Select
        Sheets(2).Copy After:=Worksheets(Worksheets.Count)
        Sheets(Sheets(2).Name & " (2)").Select
        Sheets(Sheets(2).Name & " (2)").Name = "TEST_TABLE" & Format$(i, "000")
    Next i

        .ScreenUpdating = True
    End With

    Sheets(1).Activate
    Range("A1").Select

    MsgBox ("完了")


End Sub
'------------------------------------------------------------------------------
'機能     :シートを削除する
'引数     :なし
'戻り値    :なし
'例外     :なし
'------------------------------------------------------------------------------
Sub deleteSheet()

   Dim mySht As Worksheet

   With Application
        .ScreenUpdating = False
        .DisplayAlerts = False

        For Each mySht In Worksheets
            If (mySht.Name <> ActiveSheet.Name) And (mySht.Name <> "TEST_TABLE001") Then
                mySht.Delete
            End If
        Next

        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

    Sheets(1).Activate
    Range("A1").Select

    MsgBox ("完了")

End Sub