VBA スクリプト出力(FileSystemObject)

# スクリプト生成 a-sato
## 仕様　指定した分のテーブルのデータ投入SQL文を生成(FileSystemObject)
## 仕様　文字コードは考慮していない


```vba: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







```