2018-10-25

Util

Option Explicit

' ---------------------------------------------------------------------------------------------------------------------
' 定数
' ---------------------------------------------------------------------------------------------------------------------

Public Const TITLE_NAME_PREFIX = "▼"

' ---------------------------------------------------------------------------------------------------------------------
' 変数
' ---------------------------------------------------------------------------------------------------------------------

Dim var開始時刻 As Variant

' #####################################################################################################################
' #
' # ログ系ユーティリティ
' #
' #####################################################################################################################

Sub log(ByVal strメッセージ As String)

    Debug.Print Format(Now(), "HH:mm:ss ") & strメッセージ

End Sub

' #####################################################################################################################
' #
' # ステータスバー操作系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' * 機能　：ステータスバーに表示する処理時間を初期化する
' *********************************************************************************************************************
'
Sub init開始時刻()

    var開始時刻 = Now()
    
End Sub

' *********************************************************************************************************************
' * 機能　：処理時間の開始時刻を取得する
' *********************************************************************************************************************
'
Function get開始時刻()

    get開始時刻 = var開始時刻

End Function

' *********************************************************************************************************************
' * 機能　：処理時間を HH:mm:ss 形式で取得する
' *********************************************************************************************************************
'
Function get処理時刻()

    get処理時刻 = Format(Now() - var開始時刻, "HH:mm:ss")
    
End Function

' *********************************************************************************************************************
' * 機能　：ステータスバーに経過時間付でメッセージを表示する
' *********************************************************************************************************************
'
Sub setステータスバー(ByVal strメッセージ As String)

    If IsEmpty(var開始時刻) Then
        
        var開始時刻 = Now()
        
    End If
    
    Application.StatusBar = get処理時刻() & " " & strメッセージ

End Sub

' #####################################################################################################################
' #
' # ブック、シート操作系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' * 機能　：引数で渡されたシート名以外のシートを削除する
' *********************************************************************************************************************
'
'
Function 不要シート削除(対象ブック情報 As Workbook, ByVal 残すシート名 As String)

    Dim 前状態 As Boolean
    前状態 = Application.DisplayAlerts
    
    Application.DisplayAlerts = False
    
    Dim ws As Worksheet
    
    For Each ws In 対象ブック情報.Worksheets
    
        If ws.Name <> 残すシート名 Then
            Worksheets(ws.Name).Delete
        End If
        
    Next ws
    
    Application.DisplayAlerts = 前状態
        
End Function


' #####################################################################################################################
' #
' # ダイアログ操作系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' * 機能　：処理続行 or 中止確認ダイアログを表示する
' *********************************************************************************************************************
'
Function 処理続行判断(message As String)

    Dim rc As VbMsgBoxResult
    rc = MsgBox(message + Chr(10) + "処理を続行しますか？", vbYesNo, vbQuestion)
    
    If rc = vbYes Then
        MsgBox "処理を続けます", vbInformation
    Else
        MsgBox "処理を中止しました。", vbCritical
        
        ' マクロの実行中止
        End
    End If

End Function


' #####################################################################################################################
' #
' # オートシェイプ操作系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' 機能名：対象シート上にあるオブジェクトおｎプロパティを取得する
' 戻り　：getShapesProperty as String(2, n)
'         (0, n)   type
'         (1, n)   name
'         (2, n)   TextFrame.Characters.text
'         (3, n)   Left
'         (4, n)   Top
'         (5, n)   Width
'         (6, n)   Height
'         (7, n)   TopLeftCell.Address(False, False)
'         (8, n)   TopLeftCell.row
'         (9, n)   TopLeftCell.Column
'         (10, n)  BottomRightCell.Address(False, False)
'         (11, n)  BottomRightCell.row
'         (12, n)  BottomRightCell.Column
'
' *********************************************************************************************************************
'
Function getShapesProperty(ByRef targetSheet As Worksheet, Optional ByVal objType As Long = -999, Optional ByVal formCtlType As Long = -999) As Variant

    Dim ret As Variant
    
    Dim i As Long
    Dim obj As Variant
    
    ' 配列の作成。
    i = 0
    For Each obj In targetSheet.Shapes
        ' FORMコントロールの場合
        If obj.Type = objType Then
            ' 渡されたフォームコントロールタイプが一致した場合、カウントアップ
            If obj.FormControlType = formCtlType Then
                i = i + 1
            End If
            
            ' 指定なし又は、それ以外のオートシェイプ
            ElseIf objType = -999 Or obj.Type = objType Then
                i = i + 1
            End If
    Next
        
    ' 対象のオートシェイプがみつかった場合のみ、そのオブジェクトの格納を行う。
    If 0 <> i Then
        ReDim ret(i - 1, 12)
        
        ' 配列の作成
        i = 0
        ' オブジェクト情報の設定
        For Each obj In targetSheet.Shapes
            
            ' formコントロールの場合
            If obj.Type = objType Then
                ' 渡されたフォームコrントロールタイプが一致した場合、値を取得する。
                If obj.FormControlType = formCtlType Then
                        
                    ret(i, 0) = obj.Type
                    ret(i, 1) = obj.AlternativeText
                        
                    ' TextFrameプロパティが使用できない（レイアウト枠がない）オブジェクトは除外
                    On Error Resume Next
                    ret(i, 2) = obj.ControlFormat.Value
                    ret(i, 3) = obj.Left
                    ret(i, 4) = obj.Top
                    ret(i, 5) = obj.Width
                    ret(i, 6) = obj.Height
                    ret(i, 7) = obj.TopLeftCell.Address(False, False)
                    ret(i, 8) = obj.TopLeftCell.Row
                    ret(i, 9) = obj.TopLeftCell.Column
                    ret(i, 10) = obj.Left.BottomRightCell.Address(False, False)
                    ret(i, 11) = obj.Left.BottomRightCell.Row
                    ret(i, 12) = obj.Left.BottomRightCell.Column
                        
                    i = i + 1
                End If
                    
            ' 指定なし又は、それ以外のオートシェイプなどの場合
            ElseIf objType = -999 Or obj.Type = objType Then
                
                ret(i, 0) = obj.Type
                ret(i, 1) = obj.AlternativeText
                        
                ' TextFrameプロパティが使用できない（レイアウト枠がない）オブジェクトは除外
                On Error Resume Next
                ret(i, 2) = obj.TextFrame.Characters.Text
                    
                ret(i, 3) = obj.Left
                ret(i, 4) = obj.Top
                ret(i, 5) = obj.Width
                ret(i, 6) = obj.Height
                ret(i, 7) = obj.TopLeftCell.Address(False, False)
                ret(i, 8) = obj.TopLeftCell.Row
                ret(i, 9) = obj.TopLeftCell.Column
                ret(i, 10) = obj.Left.BottomRightCell.Address(False, False)
                ret(i, 11) = obj.Left.BottomRightCell.Row
                ret(i, 12) = obj.Left.BottomRightCell.Column
                       
                i = i + 1
            End If
        Next
    End If
        
    getShapesProperty = ret
    
End Function

 


' #####################################################################################################################
' #
' # 配列操作系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' 機能　：引数が配列か判定し、配列の場合は空かどうかも判定する
' 引数　：varArray 配列
' 戻り値：判定結果（1:配列/0:空の配列/-1：配列じゃない)
' *********************************************************************************************************************
'
Public Function IsArrayEx(varArray As Variant) As Long
On Error GoTo ERROR_

    If IsArray(varArray) Then
        IsArrayEx = IIf(UBound(varArray) >= 0, 1, 0)
    Else
        IsArrayEx = -1
    End If
    
    Exit Function
    
ERROR_:
    If Err.Number = 9 Then
        IsArrayEx = 0
    End If
End Function


' *********************************************************************************************************************
' 機能　：実行結果を保持する二次元配列変数を定義するFunction
' *********************************************************************************************************************
'
Function reDimResult(ByVal topLevelElementSize As Integer, ByRef results() As Variant)

    Select Case IsArrayEx(results)
        Case 1
            ' resultsが初期化済の場合
            ' 現在のレコード数 + 1行領域を確保
            ReDim Preserve results(topLevelElementSize, UBound(results, 2) + 1)
        Case 0
            ' resultsが1度も初期化されていない場合
            ' 1行領域を確保
            ReDim Preserve results(topLevelElementSize, 0)
    End Select
        
End Function

' *********************************************************************************************************************
' 機能　：一次元配列に新たな要素を追加する
' *********************************************************************************************************************
'
Function 一次配列に値を追加(ByRef valueList As Variant, ByVal 追加設定値 As String)

    ' ファイル名を取得する
    Select Case IsArrayEx(valueList)
        Case 1
            ReDim Preserve valueList(UBound(valueList) + 1)
        Case 0
            ReDim Preserve valueList(0)
    End Select
    
    ' 追加したリストに、設定値を格納。
    valueList(UBound(valueList)) = 追加設定値
    
End Function

' *********************************************************************************************************************
' 機能　：二次元配列の行と列を入れ替える
' *********************************************************************************************************************
'
Function 二次元配列行列逆転(ByRef var二次元配列 As Variant)

    Dim var逆転後配列 As Variant
    
    ReDim var逆転後配列( _
        LBound(var二次元配列, 2) To UBound(var二次元配列, 2), _
        LBound(var二次元配列) To UBound(var二次元配列))
        
    Dim i, j As Long
    
    For i = LBound(var二次元配列) To UBound(var二次元配列, 2)
        
        For j = LBound(var二次元配列) To UBound(var二次元配列)
            
            var逆転後配列(i, j) = var二次元配列(j, i)
            
        Next
    Next
    
    二次元配列行列逆転 = var逆転後配列
        
    
End Function


' #####################################################################################################################
' #
' # 装飾系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' 機能　：対象セルにハイパーリンク数式を適用する
' *********************************************************************************************************************
'
Public Function editHYPERLINK数式( _
    ByVal strフォルダ名 As String, _
    ByVal strファイル名 As String, _
    ByVal strシート名 As String, _
    ByVal str座標 As String) As String
    
    editHYPERLINK数式 = _
        "=HYPERLINK(""[" & strフォルダ名 & "\" & strファイル名 & "]" & _
        strシート名 & "!" & str座標 & """,""" & str座標 & """)"
    
End Function
    
' *********************************************************************************************************************
' 機能　：対象セル範囲内で検索文字列に該当した文字列を赤太文字にする
' *********************************************************************************************************************
'
Function 検索該当文字の赤太文字化(prmRange As Range, prmTargetString As String)

    Dim txt As String
    Dim i, m As Integer
    Dim targetRange As Range
    
    If prmTargetString = "" Then
        Exit Function
    End If

    For Each targetRange In prmRange
        txt = targetRange.Value
        m = Len(prmTargetString)
        i = InStr(1, txt, prmTargetString)
        Do Until i = 0
            With prmRange.Characters(i, m)
                .Font.Bold = True
                .Font.ColorIndex = 3
            End With
            i = InStr(i + 1, txt, prmTargetString)
        Loop
    Next
    
    Set targetRange = Nothing
    
End Function

' #####################################################################################################################
' #
' # シート情報取得系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' 機能　：タイトル名指定でリスト値を取得
'         ※リスト値がなかった場合、配列の要素数1（値は空）が返却されます。
' *********************************************************************************************************************
'
Function タイトル名指定でリスト値を取得(titleName As String, targetSheet As Worksheet) As Variant

    Dim targetRangeList As Range
    Dim targetVariantList As Variant
    
    Set targetRangeList = タイトル名指定でリスト値のRange情報を取得(titleName, targetSheet)
    ' 配列か判定
    If targetRangeList.Count = 1 Then
        targetVariantList = Array(targetRangeList.Item(1).Value)
    Else
        targetVariantList = targetRangeList.Value
    End If
    
    タイトル名指定でリスト値を取得 = targetVariantList
    
End Function

' *********************************************************************************************************************
' 機能　：タイトル名指定でリスト値のRange情報を取得
'         ※リスト値がなかった場合、リスト値エリアの1行目（値は空）のRange情報が返却されます。
' *********************************************************************************************************************
'
Function タイトル名指定でリスト値のRange情報を取得(titleName As String, targetSheet As Worksheet) As Range

    ' 検索ヒット数
    Dim matchCount As Long
    Dim checkValue As String
    
    ' シート内にタイトル名が複数設定されていない事を確認する。
    matchCount = WorksheetFunction.CountIf(targetSheet.UsedRange, titleName)
    If 1 <> matchCount Then
        MsgBox "タイトル「" & titleName & "」が複数見つかったため、処理を中断しました。"
        End
    End If
    
    ' タイトル名のRange情報を取得
    Dim FoundCell As Range
    Set FoundCell = targetSheet.UsedRange.Find(what:=titleName, LookIn:=xlValues, _
        LookAt:=xlPart, MatchCase:=False, MatchByte:=False)
    Dim i, MaxRow, MaxCol As Long
    
    ' タイトルに対するリスト値を取得（空白行込み）
    With targetSheet
        With .Range(.Cells(FoundCell.Row, FoundCell.Column), .Cells(Rows.Count, FoundCell.Column))
            MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
            MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
        End With
    
        ' MaxRowを、空白行より一行↑のリスト値の行数に設定する。
        For i = 1 To (MaxRow - FoundCell.Row)
            checkValue = .Cells(FoundCell.Row + i, MaxCol).Value
            If "" = checkValue Or InStr(1, checkValue, TITLE_NAME_PREFIX) > 0 Then
                If 1 = i Then
                    Call 処理続行判断("タイトル名「" + titleName + "」に対するリスト値が設定されていません。")
                    MaxRow = FoundCell.Row + 1
                Else
                    MaxRow = FoundCell.Row + i - 1
                End If
                    Exit For
            End If
        Next
        
        ' リスト値を返却
        Set タイトル名指定でリスト値のRange情報を取得 = _
            targetSheet.Range(.Cells((FoundCell.Row + 1), FoundCell.Column), .Cells(MaxRow, MaxCol))
        
    End With

End Function

' *********************************************************************************************************************
' 機能　：引数で指定された行が選択状態であるか判定する
' *********************************************************************************************************************
'
Function is選択状態(ByVal lng対象行 As Long)

    Dim rng As Range
    
    For Each rng In Selection.Rows
    
        If rng.Row = lng対象行 Then
        
            is選択状態 = True
            Exit Function
            
        End If
        
    Next rng
        
    is選択状態 = False


End Function

2018-10-25

SQLUtil

Option Explicit

' ---------------------------------------------------------------------------------------------------------------------
' 定数
' ---------------------------------------------------------------------------------------------------------------------

Const cnstインデント = "   "

' ---------------------------------------------------------------------------------------------------------------------
' 変数
' ---------------------------------------------------------------------------------------------------------------------

' 対象シート
Private obj対象シート As Worksheet

' 行情報
Private lngテーブル名記載行 As Long
Private lngカラム論理名記載行 As Long
Private lngカラム物理名記載行 As Long
Private lng型桁記載行 As Long
Private lngデータ開始行 As Long
Private lngデータ終了行 As Long

' 列情報
Private lngカラム終了列 As Long

' 名称
Private txtテーブル論理名, txtテーブル物理名 As String

' 状態
Private isHidden As Boolean
Private lngDBCount結果 As Long

' ---------------------------------------------------------------------------------------------------------------------
' Property
' ---------------------------------------------------------------------------------------------------------------------

Public Property Set 隊粗油シート(ByRef arg対象シート)
    Set obj対象シート = arg対象シート
End Property

Public Property Get 対象シート() As Worksheet

    If obj対象シート Is Nothing Then
        Set obj対象シート = ActiveSheet
    End If
    
    Set 対象シート = obj対象シート
    
End Property

Public Property Get カラム論理名記載行()
    カラム論理名記載行 = lngカラム論理名記載行
End Property

Public Property Get データ開始行()
    データ開始行 = lngデータ開始行
End Property

Public Property Get データ終了行()
    データ終了行 = lngデータ終了行
End Property

Public Property Get カラム終了列()
    カラム終了列 = lngカラム終了列
End Property

' *********************************************************************************************************************
' 機能：テーブル名記載行（＝試験データテーブルの開始位置）を設定する。
' *********************************************************************************************************************
'
Public Sub setテーブル名記載行(ByVal argテーブル名記載行)

    ' 行情報の設定
    lngテーブル名記載行 = argテーブル名記載行
    lngカラム論理名記載行 = argテーブル名記載行 + 1
    lngカラム物理名記載行 = argテーブル名記載行 + 2
    lng型桁記載行 = argテーブル名記載行 + 3
    lngデータ開始行 = argテーブル名記載行 + 4
    
    ' 列情報の設定
    lngカラム終了列 = ActiveSheet.Range("B" & lngカラム物理名記載行).End(xlToRight).Column
    
    ' 名称情報の設定
    txtテーブル論理名 = ActiveSheet.Range("A" & lngテーブル名記載行).Value
    txtテーブル物理名 = ActiveSheet.Range("D" & lngテーブル名記載行).Value

    ' 表示/非表示状態(論理名列の状態で判断)
    isHidden = ActiveSheet.Cells(lngカラム論理名記載行, 1).EntireRow.Hidden

End Sub

' *********************************************************************************************************************
' 機能：指定された列番号のカラムの論理名を返却する。
' *********************************************************************************************************************
'
Public Function getカラム論倫理(ByVal arg指定カラム列 As Long) As String

    getカラム論理名 = Me.対象シート.Cells(lngカラム論理名記載行, arg指定カラム列)

End Function


' *********************************************************************************************************************
' 機能：セルに入力されているデータ件数を返却する。
' *********************************************************************************************************************
'
Public Function get件数()

    get件数 = Me.対象シート.Cells(lngテーブル名記載行, 6)

End Function

' *********************************************************************************************************************
' 機能：SELECT文に、ORDER BYを付与する。
' *********************************************************************************************************************
'
Public Function addOrderBy(ByVal txtQuery As String) As String

    Dim Re As Object: Set Re = CreateObject("VBScript.RegExp")
    Re.Pattern = "(.+? FROM)"
    
    If txtQuery Like "* UNION *" Then
    
        addOrderBy = Re.Replace(txtQuery, "SELECT * FROM ( $1") & " ) "
    
    Else
        addOrderBy = txtQuery
        
    End If

    Dim var主キー As Variant
    var主キー = get主キー()
    
    If Not IsEmpty(var主キー) Then
        addOrderBy = addOrderBy & " ORDER BY " & Join(var主キー, ", ")
    End If

End Function



' *********************************************************************************************************************
' 機能：1行のデータ行をもとにSQL文を作成する。
' 　　　データ行を指定しない場合、WHERE句なしのSELECT文を作成する。
' *********************************************************************************************************************
'
Public Function createSELECT文From単行(Optional argデータ行 As Long = -1) As String

    With ActiveSheet
        
        Dim j As Long
        Dim txtSELECT文, txtWHERE句 As String
        
        For j = 2 To lngカラム終了列
        
            ' ---------------------------------------------------------------------------------------------------------
            ' SELECT句
            ' ---------------------------------------------------------------------------------------------------------
        
            If txtSELECT文 <> "SELECT " Then
                txtSELECT文 = txtSELECT文 & ", "
            End If
        
            txtSELECT文 = txtSELECT文 & _
                editカラム値(.Cells(lngカラム物理名記載行, j).Value, .Cells(lng型桁記載行, j).Value, True)
            
            ' ---------------------------------------------------------------------------------------------------------
            ' WHERE句
            ' ---------------------------------------------------------------------------------------------------------
        
            If lngデータ行 = -1 Then
                GoTo continue
            End If
        
            If .Cells(lngデータ行, j).Value <> "" Then
        
                If txtWHERE句 <> "" Then
                    txtWHERE句 = txtWHERE句 & " AND "
                Else
                    txtWHERE句 = " WHERE "
                End If
            
                txtWHERE句 = txtWHERE句 & _
                    .Cells(lngカラム物理名記載行, j).Value & " = " & _
                    editカラム値(.Cells(argデータ行, j).Value, .Cells(lng型桁記載行, j).Value, False)
            End If
continue:
        Next j
        
    End With

    createSELECT文From単行 = txtSELECT文 & " FROM " & txtテーブル物理名 & txtWHERE句

End Function

' *********************************************************************************************************************
' 機能：複数のデータ行をもとにSQL文を作成する。
' 　　　作成するSELECT文は、1テーブル（複数行）に対し、1SELECT文（複数のSELECT文をUNIONでまとめたもの）となる。
' *********************************************************************************************************************
'
Public Function createSELECT文From複数行() As String

    Dim txtQuery As String

    If getデータ行の入力数() > 0 Then
    
        Dim j As Long
        
        For j = lngデータ開始行 To lngデータ終了業
        
            If getデータ入力数(j) > 0 Then
            
                If txtQuery <> "" Then
                    
                    txtQuery = txtQuery & vbCrLf & " UNION "
                End If
            
                txtQuery = txtQuery & createSELECT文From単行(j)
            End If
             
         Next j
         
    Else
    
        txtQuery = txtQuery & createSELECT文From単行()
        
    End If
        
    ' -----------------------------------------------------------------------------------------------------------------
    ' ORDER B句の付与
    ' -----------------------------------------------------------------------------------------------------------------
        
    createSELECT文From複数行 = addOrderBy(txtQuery)
        
End Function


' *********************************************************************************************************************
' 機能：複数のデータ行を元にSQL文を作成する。作成するSELECT文は、1データに対し、1SELECT文となる。
' *********************************************************************************************************************
'
Public Function createSELECT文From複数行To複数SQL(Optional ByVal is選択行のみ As Boolean = False) As String

    Dim txtQuery As String
    
    ' データ行のいずれかに何かしら入力されている場合
    If getデータ行の入力数() > 0 Then
    
        Dim j As Long

        For j = lngデータ開始行 To lngデータ終了行
        
            If is選択行のみ And Not is選択状態(j) Then ' 選択行のみSQL文作成対象にする場合の考慮
            
                GoTo jContinue
            End If
            
            If getデータ行の入力数(j) > 0 Then
            
                txtQuery = txtQuery & addOrderBy(createSELECT文From単行(j)) & ";" & vbCrLf
            
            End If
jContinue:

        Next j

    End If

    ' 前処理でSQLが作成されていない場合
    
    If txtQuery = "" Then
    
        Dim k As Long
        
        For k = lngデータ開始行 To lngデータ終了行
        
            If is選択行のみ And Not is選択状態(k) Then ' 選択行のみSQL文作成対象にする場合の考慮
                ' 何もしない
            Else
            
                txtQuery = addOrderBy(createSELECT文Fromt単行()) & ";" & vbCrLf
                Exit For ' 複数行選択されていても、同じSQLになるので1行だけ作成する
            End If
        Next k
    End If

    If strQuery <> "" Then
    
        strQuery = vbCrLf & "-- " & txtテーブル論理名 & " " & txtテーブル論理名 & vbCrLf & txtQuery
        createSELECT文From複数行To複数SQL = txtQuery
        
    End If
        
End Function

' *********************************************************************************************************************
' 機能：INSERT文を作成する
' *********************************************************************************************************************
'
Public Function createInsert文(ByVal is選択行のみ As Boolean) As String

    Dim txt結果 As String
    
    With Me.対象シート
    
        If .Range("B" & lngデータ開始行).Value = "" Then
        
            Exit Function ' データがない場合、INSERT文の作成はしない
        End If
        
        Dim j, k As Long
        
        ' データ行、1行ごとの処理
        For j = lngデータ開始行 To lngデータ終了行
        
            If .Range("B" & j).Value = "" Then
            
                GoTo jContinue
            End If
            
            If is選択行のみ And Not is選択状態(j) Then ' 選択行のみSQL文作成対象にする場合の考慮
            
                GoTo jContinue
            End If
            
            Dim txtInsertInto As String: txtInsertInto = "INSERT INTO " & txtテーブル物理名 & " ("
            Dim txtInsertValues As String: txtInsertValues = " VALUES ("
            
            For k = 2 To lngカラム終了列
            
                If k > 2 Then
                    txtInsertInto = txtInsertInto & ", "
                    txtInsertValues = txtInsertValues & ", "
                End If
                
                txtInsertInto = txtInsertInto & .Cells(lngカラム物理名記載行, k)
                txtInsertValues = txtInsertValues & editカラム値(.Cells(j, k), .Cells(lng型桁記載行, k))
            Next k
            
            txt結果 = txt結果 & txtInsertInto & ")" & vbCrLf & "   " & txtInsertValues & ");" & vbCrLf
            
jContinue:
        Next j
        
    End With

    If txt結果 <> "" Then
        txt結果 = vbCrLf & "-- " & txtテーブル論理名 & " " & txtテーブル物理名 & vbCrLf & txt結果
        createInsert文 = txt結果
    End If

End Function

' *********************************************************************************************************************
' 機能：UPDATE文を作成する
' *********************************************************************************************************************
'
Public Function createUpdate文(ByVal is選択行のみ As Boolean) As String

    Dim txt結果 As String
    
    With Me.対象シート
    
        If .Range("B" & lngデータ開始行).Value = "" Then
        
            Exit Function ' データがない場合、UPDATE文の作成はしない
        End If
        
        Dim var主キー As Variant
        var主キー = Me.get主キー()
        
        Dim j, k As Long
        
        ' データ行、1行ごとの処理
        For j = lngデータ開始行 To lngデータ終了行
        
            If .Range("B" & j).Value = "" Then
            
                GoTo jContinue
            End If
            
            If is選択行のみ And Not is選択状態(j) Then ' 選択行のみSQL文作成対象にする場合の考慮
            
                GoTo jContinue
            End If
            
            Dim txtUpdate As String: txtUpdate = "UPDATE " & txtテーブル物理名 & " SET "
            Dim txtWHERE As String: txtWHERE = " WHERE "
            
            For k = 2 To lngカラム終了列
            
                If containArray(var主キー, .Cells(lngカラム物理名記載行, k)) Then
                
                    If txtWHERE <> " WHERE " Then
                    
                        txtWHERE = txtWHERE & " AND "
                    End If
            
                    txtWHERE = txtWHERE & .Cells(lngカラム物理名記載行, k) _
                        & " = " & editカラム値(.Cells(j, k), .Cells(lng型桁記載行, k))
                Else
                    If Not txtUpdate Like "* SET " Then
                    
                        txtUpdate = txtUpdate & " , "
                    End If
                    
                    txtUpdate = txtUpdate & .Cells(lngカラム物理名記載行, k) _
                        & " = " & editカラム値(.Cells(j, k), .Cells(lng型桁記載行, k))
                End If
                
            Next k
            
            txt結果 = txt結果 & txtUpdate & vbCrLf & "   " & txtWHERE & ";" & vbCrLf
            
jContinue:
        Next j
        
    End With

    If txt結果 <> "" Then
        txt結果 = vbCrLf & "-- " & txtテーブル論理名 & " " & txtテーブル物理名 & vbCrLf & txt結果
        createInsert文 = txt結果
    End If

End Function

' *********************************************************************************************************************
' 機能：DELETE文を作成する
' *********************************************************************************************************************
'
Public Function createDelete文(ByVal is選択行のみ As Boolean) As String

    Dim Re As Object: Set Re = CreateObject("VBScript.RegExp")
    Re.Global = True
    Re.Pattern = "SELECT.+? FROM "

    Dim txt結果 As String
    txt結果 = Re.Replace(createSELECT文From複数行To複数SQL(is選択行のみ), "DELETE FROM ")
    
    Re.Pattern = " ORDER BY .+?;"
    createDelete文 = Re.Replace(str結果, ";")

End Function

' *********************************************************************************************************************
' 機能：SELECT文を、COUNTを行うSQLに変更する。
' *********************************************************************************************************************
'
Public Function createCount文(ByVal txtQuery As String) As String

    Dim Re As Object: Set Re = CreateObject("VBScript.RegExp")
    Re.Pattern = "(SELECT .+ FROM)"
    
    createCount文 = Re.Replace(txtQuery, "SELECT COUNT(*) AS COUNT FROM")
    
End Function
' *********************************************************************************************************************
' 機能：枠をクリップボードにコピーする
' *********************************************************************************************************************
'
Public Sub copy枠Toクリップボード()

    ActiveWorkbook.ActiveSheet.Rows(lngテーブル名記載行 & ":" & lngデータ開始行).Copy
    
End Sub


' *********************************************************************************************************************
' 機能：データ行の内容をクリアする
' *********************************************************************************************************************
'
Public Sub clearデータ行()

    Me.対象シート.Rows(lngデータ開始行 & ";" & lngデータ終了行).ClearContents ' 内容をクリア
    Me.対象シート.Rows(lngデータ開始行 & ";" & lngデータ終了行).ClearComments ' コメントをクリア
    
End Sub

' *********************************************************************************************************************
' 機能：引数で指定された自動設定値と同一のカラム名がテーブル内に存在する場合、設定値を1行目にセットする。
' *********************************************************************************************************************
'
Public Sub set抽出条件(ByVal var自動設定値 As Variant)

    With Me.対象シート
    
        Dim i As Long
        For i = 2 To lngカラム終了列
    
            Dim j As Long
            For j = LBound(var自動設定値) To UBound(var自動設定値)
        
                If .Cells(lngカラム物理名記載行, i) = var自動設定値(j, 1) Then
            
                    .Cells(lngカラム物理名記載行, i) = var自動設定値(j, 2)
                
                End If
            Next j
        Next i
    End With
End Sub

' *********************************************************************************************************************
' 機能：指定された行に空行を作成する
' *********************************************************************************************************************
'
Public Sub add空行(ByVal arg追加行番号 As Long)

    Me.対象シート.Rows(lngデータ開始行).Copy  ' データ行の1行目から書式コピー
    Me.対象シート.Rows(arg追加行番号).Insert ' 行追加
    Me.対象シート.Rows(arg追加行番号).ClearContens ' 内容をクリア
    Me.対象シート.Rows(arg追加行番号).ClearComments ' コメントをクリア
    
    Application.CutCopyMode = False
    
End Sub


' *********************************************************************************************************************
' 機能：選択された行を黄色で着色
' *********************************************************************************************************************
'
Public Sub edit選択行強調(ByVal arg選択行番号 As Long)

    With Me.対象シート
    
        Call Me.edit変更強調色(.Range(.Cells(arg選択行番号, 2), .Cells(arg選択行番号, lngカラム終了列)))

    End With

End Sub

' *********************************************************************************************************************
' 機能：選択された行を網掛
' *********************************************************************************************************************
'
Public Sub edit選択行網掛(ByVal arg選択行番号 As Long)

    With Me.対象シート
    
        Call Me.edit網掛(.Range(.Cells(arg選択行番号, 2), .Cells(arg選択行番号, lngカラム終了列)))
        
    End With

End Sub

' *********************************************************************************************************************
' 機能：選択された範囲を網掛け
' *********************************************************************************************************************
'
Public Sub edit変更強調色(ByRef arg修飾範囲 As Range)

    With arg修飾範囲.Interior
        .Pattern = xlGray16
        .PatternColorIndex = xlAutomatic
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

End Sub

' *********************************************************************************************************************
' 機能：指定された主キー項目を連結した文字列を返却する
' *********************************************************************************************************************
'
Function get主キー項目連結文字列(ByVal arg対象データ行 As Long) As String

    get主キー項目連結文字列 = Join(get主キー(lng対象データ行))

End Function

' *********************************************************************************************************************
' 機能：データ行の入力数を返却する。
' *********************************************************************************************************************
'
Private Function getデータ行の入力数(Optional arg対象データ行 = -1)

    With ActiveSheet
    
        If arg対象データ行 = -1 Then
        
            getデータ行の入力数 = WorksheetFunction.CountA( _
                .Range(.Cells(lngデータ開始行, 2), .Cells(lngデータ終了行, lngカラム終了列)))
            
        Else
            
            getデータ行の入力数 = WorksheetFunction.CountA( _
                .Range(.Cells(arg対象データ行, 2), .Cells(arg対象データ行, lngカラム終了列)))
                
        End If
            
    End With

End Function

' *********************************************************************************************************************
' 機能：主キーを配列で返却する
' *********************************************************************************************************************
'
Public Function get主キー(Optional ByVal arg対象データ行 As Long = -1) As Variant

    If arg対象データ行 = -1 Then
        arg対象データ行 = lngカラム論理名記載行
    End If

    Dim var主キー As Variant
    ReDim var主キー(1 To lngカラム終了列) ' 予想され得る最大値＝カラム数で配列を確保
    
    Dim i, lng主キー数 As Long
    
    For i = 2 To lngカラム終了列
    
        With Me.対象シート
        
            ' 主キーカラムであるか否かを、背景色で判断
            If .Cells(lngカラム物理名記載行, i).Interior.ThemeColor = xlThemeColorAccent2 Then
                
                lng主キー数 = lng主キー数 + 1
                var主キー(lng主キー数) = .Cells(arg対象データ行, i).Value
                
            End If
        End With
    Next
    
    If lng主キー数 = 0 Then
    
        get主キー = Empty
    Else
    
        ReDim Preserve var主キー(1 To lng主キー数)
        get主キー = var主キー
        
    End If
    
End Function


' *********************************************************************************************************************
' 機能：カラムに対する値を型桁に合わせて加工する(チェック機能付)
' *********************************************************************************************************************
'
Private Function editカラム値( _
    ByVal argカラム値 As String, ByVal arg型桁 As String, Optional ByVal is列名 = False) As String
    
    If argカラム値 = "" Then
        editカラム値 = "NULL"
        Exit Function
    End If
    
    ' -----------------------------------------------------------------------------------------------------------------
    ' DATE型
    ' -----------------------------------------------------------------------------------------------------------------
    '
    If argカラム値 Like "DATE*" Then
    
        If UCase(argカラム値) = "SYSTIMESTAMP" Or UCase(argカラム値) = "SYSDATE" Then
        
            editカラム値 = argカラム値
        Else
            If is列名 Then
                editカラム値 = "TO_CHAR(" & argカラム値 & ", 'YYYY/MM/DD HH24:MI:SS')"
            Else
                editカラム値 = "TO_DATE('" & argカラム値 & "', 'YYYY/MM/DD HH24:MI:SS')"
            End If
        End If
    
    ' -----------------------------------------------------------------------------------------------------------------
    ' DATE型
    ' -----------------------------------------------------------------------------------------------------------------
    '
    ElseIf arg型桁 Like "TIMESTAMP*" Then
        
        If UCase(argカラム値) = "SYSTIMESTAMP" Or UCase(argカラム値) = "SYSDATE" Then
        
            editカラム値 = argカラム値
        Else
            If is列名 Then
                editカラム値 = "TO_CHAR(" & argカラム値 & ", 'YYYY/MM/DD HH24:MI:SS.FF6')"
            Else
                editカラム値 = "TO_TIMESTAMP('" & argカラム値 & "', 'YYYY/MM/DD HH24:MI:SS.FF6')"
                
            End If
        End If

    ' -----------------------------------------------------------------------------------------------------------------
    ' DATE型
    ' -----------------------------------------------------------------------------------------------------------------
    '
    ElseIf argカラム値 Like "NUMBER*" Then
    
        editカラム値 = argカラム値

    ' -----------------------------------------------------------------------------------------------------------------
    ' VARCHAR2,CHAR型
    ' -----------------------------------------------------------------------------------------------------------------
    '
    ElseIf arg型桁 Like "VARCHAR2*" Or arg型桁 Like "CHAR*" Then
    
        If is列名 Then
            editカラム値 = argカラム値
        Else
            editカラム値 = "'" & argカラム値 & "'"
        End If
        
    Else
        MsgBox "処理できない型：" & arg型桁
    End If

End Function

2018-10-25

初期設定

Public globalWb前回実行結果 As Workbook

Sub グループ表示非表示の切り替え()

    Dim obj試験データシート As cls試験データシート
    Set obj試験データシート = New cls試験データシート
    
    obj試験データシート.表示非表示の切替
    
End Sub

Sub createSELECT文()

    frmSQL生成.Show
    
    Excel.Application.CutCopyMode = False
    
End Sub

Sub set抽出条件()

    Dim obj設定シート As cls設定シート
    Set obj設定シート = New cls設定シート
    
    obj設定シート.set抽出条件

End Sub

Sub Auto_Open()

    Application.OnKey "{F9}", "createSELECT文"

End Sub

2018-10-25

FileOperationUtil

Option Explicit

' ---------------------------------------------------------------------------------------------------------------------
' 定数
' ---------------------------------------------------------------------------------------------------------------------

'パスのデリミタ
Public Const PATH_DELIMITER = "\"

' ファイル名、拡張子のデリミタ
Public Const FILE_DELIMITER = "."

' ファイル操作情報
Public Type ファイル操作情報
    フルパス_ファイル名 As String
    フルパス As String
    親ディレクトリまでのフルパス As String
    対象ディレクトリ名 As String
    対象ファイル名 As String
    対象ファイル情報() As String
End Type

' 対象の拡張子（モジュール）
Public Const FILE_EXTENSION_OF_MODULE = "bas,cls,frm"

' ファイルCLOSE状態区分
Public Enum ファイルCLOSE方法区分
    保存しないで閉じる = 0
    保存して閉じる = 1
    保存しないで閉じない = 2
    保存して閉じない = 3
    処理中断 = 99
End Enum

' ---------------------------------------------------------------------------------------------------------------------
' 変数
' ---------------------------------------------------------------------------------------------------------------------

' ルートパス作成済フラグ
Private rootPathMaked As Boolean

' #####################################################################################################################
' #
' # アクセサ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' * 機能　：ルートパス作成済みフラグを設定する
' *********************************************************************************************************************
'
Public Function getRootPathMaked() As Boolean
    getRootPathMaked = rootPathMaked
End Function

' *********************************************************************************************************************
' * 機能　：ルートパス作成済みフラグを取得する
' *********************************************************************************************************************
'
Public Function setRootPathMaked(isMaked As Boolean)
    rootPathMaked = isMaked
End Function

' #####################################################################################################################
' #
' # ファイル操作ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' * 機能　：パス（パス＆ファイル）の存在チェック
' * 引数　：directoryPath パス（または、パス＆ファイル）
' * 戻り値：チェック結果（パス存在時は1、ファイル存在時は2、パスもファイルも存在しない場合は-1）
' *********************************************************************************************************************
'
Function isDirectoryExist(directoryPath As String) As Long

    Dim FSO
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If True = FSO.FileExists(directoryPath) Then
        isDirectoryExist = 2
    ElseIf True = FSO.FolderExists(directoryPath) Then
        isDirectoryExist = 1
    Else
        isDirectoryExist = -1
    End If
        
End Function

' *********************************************************************************************************************
' * 機能　：パス配下の階層全てのディレクトリを処理する
' * 引数　：directoryPath パス
' * 戻り値：実行結果（カレントディレクトリを含む、配下のディレクトリ名の配列
' *********************************************************************************************************************
'
Function doRepeat(ByVal directoryPath As String, ByVal fileExtensions As Variant, _
    ByRef fileNames() As String, Optional ByVal recursive As Boolean = False)
    
    ' 検索結果
    Dim buf As String, msg As String, dirName As Variant
    
    ' 配下のパス情報
    Dim directoryPathBySub As String
    directoryPathBySub = directoryPath
    
    ' 直下のディレクトリ存在可否フラグ
    Dim isExistDir As Boolean
    isExistDir = False
    
    Dim dirNames() As String
    
    Dim resultArray As Variant
    
    If "" <> directoryPath Then
        ' ディレクトリ移動
        ChDir directoryPath
        
        ' -------------------------------------------------------------------------------------------------------------
        ' 直下のファイル名を全て取得
        ' -------------------------------------------------------------------------------------------------------------
        Call getFileNames(directoryPath, fileExtensions, fileNames)
        
        If recursive Then
        
            ' ---------------------------------------------------------------------------------------------------------
            ' 直下のディレクトリ名を全て取得
            ' ---------------------------------------------------------------------------------------------------------
            dirNames = getDirNames(directoryPath)
            
            ' ---------------------------------------------------------------------------------------------------------
            ' 取得したディレクトリ名1つずつ再帰的に処理する。
            ' ---------------------------------------------------------------------------------------------------------
            If Not Not dirNames Then
                For Each dirName In dirNames
                    Call doRepeat(dirName, fileExtensions, fileNames, True)
                Next
            End If
            
        End If
        
    End If
    
End Function

' *********************************************************************************************************************
' * 機能　：パス直下のファイル名を全て取得
' * 引数　：directoryPath パス
' * 戻り値：実行結果（カレントディレクトリ直下のディレクトリ名の配列。）
' *********************************************************************************************************************
'
Function getFileNames(directoryPath As String, fileExtensions As Variant, ByRef fileNames() As String)

    Dim fileName As String, msg As String
    
    Dim fileNameSize As Integer
    
    Dim fileExtension As Variant
    
    ' ディレクトリ移動
    ChDir directoryPath
    
    ' -----------------------------------------------------------------------------------------------------------------
    ' 直下のファイル名を全て取得
    ' -----------------------------------------------------------------------------------------------------------------
    fileName = Dir(directoryPath & "\" & "*.*")
    
    Do While fileName <> ""
    
        ' ファイル名取得
        For Each fileExtension In fileExtensions
            If InStr(1, UCase(fileName), UCase(fileExtension)) > 0 Then
            
                ' フルパス＆ファイル名を追加格納。
                Call 一次配列に値を追加(fileNames, directoryPath & "\" & fileName)
                Exit For
        
            End If
        Next
    
        fileName = Dir()
    Loop

End Function

' *********************************************************************************************************************
' * 機能　：パス直下のディレクトリ名を全て取得
' * 引数　：directoryPath パス
' * 戻り値：実行結果（カレントディレクトリ直下のディレクトリ名の配列。）
' *********************************************************************************************************************
'
Function getDirNames(directoryPath As String) As String()
    Dim buf As String
    
    Dim dirNames() As String
    
    ' ディレクトリ移動
    ChDir directoryPath
    
    buf = Dif(directoryPath & "\" & "*.*", vbDirectory)
    Do While buf <> ""
        ' ディレクトリ名取得
        If GetAttr(directoryPath & "\" & buf) And vbDirectory Then
            If buf <> "." And buf <> ".." Then
            
                ' ディレクトリ名を追加格納。
                Call 一次元配列に値を追加(dirNames, directoryPath & "\" & buf)
                
            End If
        End If
        buf = Dir()
        
    Loop
    
    getDirNames = dirNames

End Function


' *********************************************************************************************************************
' * 機能　：対象ディレクトリを作成する（対象パスが未存在、作成ディレクトリ名が存在した場合は処理中断）
' *********************************************************************************************************************
'
Function ディレクトリ作成(ByVal ルートパス As String, ByVal 処理日時 As String, ByVal 相対パス As String)

    Dim dirCheck As Long
    
    ' ルートパスの存在チェック
    dirCheck = isDirectoryExist(CStr(ルートパス & 処理日時))
    ' 対象パスが未設定の場合（ルートパス作成時）
    If "" = 相対パス Then
        ' 処理日時が設定済の場合、ルートパスが作成済であれば処理中断とする
        If "" <> 処理日時 Then
            If 0 < dirCheck And False = getRootPathMaked() Then
                MsgBox "以下のディレクトリは既に存在するため処理を中断します。" + Chr(10) + "「" + ルートパス & 処理日時 + "」"
                End
            End If
        End If
    End If

    ' ディレクトリ作成
    dirCheck = isDirectoryExist(CStr(ルートパス & 処理日時 & PATH_DELIMITER & 相対パス))
    If 0 > dirCheck Then
        MkDir ルートパス & 処理日時 & PATH_DELIMITER & 相対パス
        Call setRootPathMaked(True)
    End If
    
End Function

2018-10-25

frmSQL生成

Public wb起動元ブック As Workbook
Public wb前回実行結果 As Workbook

Private Sub btnSQL生成_Click()

    wb起動元ブック.Activate
    
    Dim obj試験データシート As cls試験データシート
    Set obj試験データシート = New cls試験データシート
    
    Dim obj対象シート As Worksheet
    Set obj対象シート = ActiveSheet
    
    If rdo現在のシート.Value = True Then
    
        txtSQL.Value = vbCrLf & "-- シート名：" & obj対象シート.Name & vbLf & _
            createSQL文(obj試験データシート, obj対象シート)
    Else
    
        Dim strSQL As String
        
        For Each obj対象シート In ActiveWorkbook.Sheets
        
            obj対象シート.Activate
            
            strSQL = strSQL & vbLf & "-- シート名：" & obj対象シート.Name
            strSQL = strSQL & createSQL文(obj試験データシート, obj対象シート)
            
        Next
        
        txtSQL.Value = strSQL
    
    End If
    
End Sub

Private Function createSQL文( _
    ByRef obj試験データシート As cls試験データシート, _
    ByRef obj対象シート As Worksheet) As String
    
    If rdInsert Then
        createSQL文 = obj試験データシート.対象シートINSERT文作成(obj対象シート)
        
    ElseIf rdUpdate Then
    
    ElseIf rdSelect Then
    
    ElseIf rdDelete Then
    
    End If
    
End Function
        
Private Sub btnレコード取得_Click()

    log "レコード取得処理開始"
    
    wb起動元ブック.Activate
    
    Dim obj試験データシート As cls試験データシート
    Set obj試験データシート = New cls試験データシート
    
    Set wb前回実行結果 = obj試験データシート.getレコード(Nothing)
    
    If Not (wb前回実行結果 Is Nothing) Then
        Application.CutCopyMode = False
        
        wb前回実行結果.Activate
        wb前回実行結果.ActiveSheet.Range("A1").Select
        
        btnレコード追加取得.Enabled = True
        
    End If
    
    log "レコード取得処理終了"
    
End Sub

Private Sub btnレコード追加取得_Click()

    log "レコード追加取得処理開始"
    
    wb起動元ブック.Activate
    
    Dim obj試験データシート As cls試験データシート
    Set obj試験データシート = New cls試験データシート
    
    Set wb前回実行結果 = obj試験データシート.getレコード(wb前回実行結果)
    
    If Not (wb前回実行結果 Is Nothing) Then
    
        Application.CutCopyMode = False
        wb前回実行結果.Activate
        wb前回実行結果.ActiveSheet.Range("A1").Select
        
        Call obj試験データシート.edit実行結果差分(wb前回実行結果)
        
    End If
    
    log "レコード追加取得処理終了"
    
End Sub

Private Sub UserForm_Initialize()

    Set wb起動元ブック = ActiveWorkbook
    
    btnSQL生成.SetFocus
    
End Sub

2018-10-23

cls設定シート

Option Explicit

' ---------------------------------------------------------------------------------------------------------------------
' 定数
' ---------------------------------------------------------------------------------------------------------------------

Const cnstシート名 = "設定"
Const cnst設定項目 = "▼設定項目"

' *********************************************************************************************************************
' 接続文字列の取得
' *********************************************************************************************************************
'
Public Function getConnectionString()

    Dim obj設定値リスト As Variant
    Set obj設定値リスト = タイトル名指定でリスト値のRange情報を取得(cnst設定項目, ThisWorkbook.Sheets(cnstシート名))
    
    Dim txt接続文字列 As String
    ' txt接続文字列 = "Provider=OraOLEDB.Oracle;"
    
    Dim i As Long
    Dim obj設定値
    For Each obj設定値 In obj設定値リスト
    
        txt接続文字列 = txt接続文字列 & obj設定値 & "=" & obj設定値.Offset(0, 1) & ";"
        
    Next obj設定値
    
    getConnectionString = txt接続文字列

End Function

2018-10-23

cls試験データテーブル

Option Explicit

' ---------------------------------------------------------------------------------------------------------------------
' 定数
' ---------------------------------------------------------------------------------------------------------------------

Const cnstインデント = "   "

' ---------------------------------------------------------------------------------------------------------------------
' 変数
' ---------------------------------------------------------------------------------------------------------------------

' 対象シート
Private obj対象シート As Worksheet

' 行情報
Private lngテーブル名記載行 As Long
Private lngカラム論理名記載行 As Long
Private lngカラム物理名記載行 As Long
Private lng型桁記載行 As Long
Private lng制約記載行 As Long
Private lngデータ開始行 As Long
Private lngデータ終了行 As Long

' 列情報
Private lngカラム終了列 As Long

' 名称
Private txtテーブル論理名, txtテーブル物理名 As String

' 状態
Private isHidden As Boolean
Private lngDBCount結果 As Long

' ---------------------------------------------------------------------------------------------------------------------
' Property
' ---------------------------------------------------------------------------------------------------------------------

Public Property Set 対象シート(ByRef arg対象シート)
    Set obj対象シート = arg対象シート
End Property

Public Property Get 対象シート() As Worksheet

    If obj対象シート Is Nothing Then
        Set obj対象シート = ActiveSheet
    End If
    
    Set 対象シート = obj対象シート
    
End Property

Public Property Get カラム論理名記載行()
    カラム論理名記載行 = lngカラム論理名記載行
End Property

Public Property Get データ開始行()
    データ開始行 = lngデータ開始行
End Property

Public Property Get データ終了行()
    データ終了行 = lngデータ終了行
End Property

Public Property Get カラム終了列()
    カラム終了列 = lngカラム終了列
End Property

' *********************************************************************************************************************
' 機能：テーブル名記載行（＝試験データテーブルの開始位置）を設定する。
' *********************************************************************************************************************
'
Public Sub setテーブル名記載行(ByVal argテーブル名記載行)

    ' 行情報の設定
    lngテーブル名記載行 = argテーブル名記載行
    lngカラム物理名記載行 = argテーブル名記載行 + 1
    lngカラム論理名記載行 = argテーブル名記載行 + 2
    lng型桁記載行 = argテーブル名記載行 + 3
    lng制約記載行 = argテーブル名記載行 + 4
    lngデータ開始行 = argテーブル名記載行 + 5
    
    ' 列情報の設定
    lngカラム終了列 = ActiveSheet.Range("B" & lngカラム物理名記載行).End(xlToRight).Column
    
    ' 名称情報の設定
    txtテーブル論理名 = ActiveSheet.Range("C" & lngテーブル名記載行).Value
    txtテーブル物理名 = ActiveSheet.Range("A" & lngテーブル名記載行).Value

    ' 表示/非表示状態(論理名列の状態で判断)
    isHidden = ActiveSheet.Cells(lngカラム論理名記載行, 1).EntireRow.Hidden

End Sub


' *********************************************************************************************************************
' 機能：テーブル名記載行（＝試験データテーブルの開始位置）を返却する。
' *********************************************************************************************************************
'
Public Function getテーブル名記載行() As Long

    getテーブル名記載行 = lngテーブル名記載行

End Function


' *********************************************************************************************************************
' 機能：データ終了位置を設定する。本項目については、他テーブル
' *********************************************************************************************************************
'
Public Sub setデータ終了行(ByVal param As Long)

    lngデータ終了行 = param
    
End Sub


' *********************************************************************************************************************
' 機能：非表示かどうかを示す
' *********************************************************************************************************************
'
Public Function Hidden()

    Hidden = isHidden
    
End Function


' *********************************************************************************************************************
' 機能：テーブル論理名を返却する。
' *********************************************************************************************************************
'
Public Function getテーブル物理名()

    getテーブル物理名 = txtテーブル物理名

End Function

' *********************************************************************************************************************
' 機能：テーブル物理名を返却する。
' *********************************************************************************************************************
'
Public Function getテーブル論理名()

    getテーブル論理名 = txtテーブル論理名

End Function

' *********************************************************************************************************************
' 機能：指定された列番号のカラムの論理名を返却する。
' *********************************************************************************************************************
'
Public Function getカラム論理名(ByVal arg指定カラム列 As Long) As String

    getカラム論理名 = Me.対象シート.Cells(lngカラム論理名記載行, arg指定カラム列)

End Function

' *********************************************************************************************************************
' 機能：DBカウント結果を返却する。
' *********************************************************************************************************************
'
Public Function setDBCount結果(ByVal param As Long)

    lngDBCount結果 = param
    
End Function

' *********************************************************************************************************************
' 機能：DBカウント結果を設定する。
' *********************************************************************************************************************
'
Public Function getDBCount結果() As Long

    getDBCount結果 = lngDBCount結果
    
End Function


' *********************************************************************************************************************
' 機能：セルに入力されているデータ件数を返却する。
' *********************************************************************************************************************
'
Public Function get件数()

    get件数 = Me.対象シート.Cells(lngテーブル名記載行, 6)

End Function

' *********************************************************************************************************************
' 機能：SELECT文に、ORDER BYを付与する。
' *********************************************************************************************************************
'
Public Function addOrderBy(ByVal txtQuery As String) As String

    Dim Re As Object: Set Re = CreateObject("VBScript.RegExp")
    Re.Pattern = "(.+? FROM)"
    
    If txtQuery Like "* UNION *" Then
    
        addOrderBy = Re.Replace(txtQuery, "SELECT * FROM ( $1") & " ) AS DUMMY "
    
    Else
        addOrderBy = txtQuery
        
    End If

    Dim var主キー As Variant
    var主キー = get主キー()
    
    If Not IsEmpty(var主キー) Then
        addOrderBy = addOrderBy & " ORDER BY " & Join(var主キー, ", ")
    End If

End Function



' *********************************************************************************************************************
' 機能：1行のデータ行をもとにSQL文を作成する。
' 　　　データ行を指定しない場合、WHERE句なしのSELECT文を作成する。
' *********************************************************************************************************************
'
Public Function createSELECT文From単行(Optional argデータ行 As Long = -1) As String

    With ActiveSheet
        
        Dim j As Long
        Dim txtSELECT文, txtWHERE句 As String
        
        txtSELECT文 = "SELECT "
        txtWHERE句 = ""
        
        For j = 2 To lngカラム終了列
        
            ' ---------------------------------------------------------------------------------------------------------
            ' SELECT句
            ' ---------------------------------------------------------------------------------------------------------
        
            If txtSELECT文 <> "SELECT " Then
                txtSELECT文 = txtSELECT文 & ", "
            End If
        
            txtSELECT文 = txtSELECT文 & _
                editカラム値(.Cells(lngカラム物理名記載行, j).Value, .Cells(lng型桁記載行, j).Value, True)
            
            ' ---------------------------------------------------------------------------------------------------------
            ' WHERE句
            ' ---------------------------------------------------------------------------------------------------------
        
            If argデータ行 = -1 Then
                GoTo continue
            End If
        
            If .Cells(argデータ行, j).Value <> "" Then
        
                If txtWHERE句 <> "" Then
                    txtWHERE句 = txtWHERE句 & " AND "
                Else
                    txtWHERE句 = " WHERE "
                End If
            
                txtWHERE句 = txtWHERE句 & _
                    .Cells(lngカラム物理名記載行, j).Value & " = " & _
                    editカラム値(.Cells(argデータ行, j).Value, .Cells(lng型桁記載行, j).Value, False)
            End If
continue:
        Next j
        
    End With

    createSELECT文From単行 = txtSELECT文 & " FROM " & txtテーブル物理名 & txtWHERE句

End Function

' *********************************************************************************************************************
' 機能：複数のデータ行をもとにSQL文を作成する。
' 　　　作成するSELECT文は、1テーブル（複数行）に対し、1SELECT文（複数のSELECT文をUNIONでまとめたもの）となる。
' *********************************************************************************************************************
'
Public Function createSELECT文From複数行() As String

    Dim txtQuery As String

    If getデータ行の入力数() > 0 Then
    
        Dim j As Long
        
        For j = lngデータ開始行 To lngデータ終了行
        
            If getデータ行の入力数(j) > 0 Then
            
                If txtQuery <> "" Then
                    
                    txtQuery = txtQuery & vbCrLf & " UNION "
                End If
            
                txtQuery = txtQuery & createSELECT文From単行(j)
            End If
             
         Next j
         
    Else
    
        txtQuery = txtQuery & createSELECT文From単行()
        
    End If
        
    ' -----------------------------------------------------------------------------------------------------------------
    ' ORDER B句の付与
    ' -----------------------------------------------------------------------------------------------------------------
        
    createSELECT文From複数行 = addOrderBy(txtQuery)
        
End Function


' *********************************************************************************************************************
' 機能：複数のデータ行を元にSQL文を作成する。作成するSELECT文は、1データに対し、1SELECT文となる。
' *********************************************************************************************************************
'
Public Function createSELECT文From複数行To複数SQL(Optional ByVal is選択行のみ As Boolean = False) As String

    Dim txtQuery As String
    
    ' データ行のいずれかに何かしら入力されている場合
    If getデータ行の入力数() > 0 Then
    
        Dim j As Long

        For j = lngデータ開始行 To lngデータ終了行
        
            If is選択行のみ And Not is選択状態(j) Then ' 選択行のみSQL文作成対象にする場合の考慮
            
                GoTo jContinue
            End If
            
            If getデータ行の入力数(j) > 0 Then
            
                txtQuery = txtQuery & addOrderBy(createSELECT文From単行(j)) & ";" & vbCrLf
            
            End If
jContinue:

        Next j

    End If

    ' 前処理でSQLが作成されていない場合
    
    If txtQuery = "" Then
    
        Dim k As Long
        
        For k = lngデータ開始行 To lngデータ終了行
        
            If is選択行のみ And Not is選択状態(k) Then ' 選択行のみSQL文作成対象にする場合の考慮
                ' 何もしない
            Else
            
                txtQuery = addOrderBy(createSELECT文Fromt単行()) & ";" & vbCrLf
                Exit For ' 複数行選択されていても、同じSQLになるので1行だけ作成する
            End If
        Next k
    End If

    If strQuery <> "" Then
    
        strQuery = vbCrLf & "-- " & txtテーブル論理名 & " " & txtテーブル論理名 & vbCrLf & txtQuery
        createSELECT文From複数行To複数SQL = txtQuery
        
    End If
        
End Function

' *********************************************************************************************************************
' 機能：INSERT文を作成する
' *********************************************************************************************************************
'
Public Function createInsert文(ByRef obj引数対象シート As Worksheet, Optional ByVal is選択行のみ As Boolean = False) As String

    Dim txt結果 As String
    
    With obj引数対象シート
    
        If .Range("B" & lngデータ開始行).Value = "" Then
        
            Exit Function ' データがない場合、INSERT文の作成はしない
        End If
        
        Dim j, k As Long
        
        ' データ行、1行ごとの処理
        For j = lngデータ開始行 To lngデータ終了行
        
            If .Range("B" & j).Value = "" Then
            
                GoTo jContinue
            End If
            
            If is選択行のみ And Not is選択状態(j) Then ' 選択行のみSQL文作成対象にする場合の考慮
            
                GoTo jContinue
            End If
            
            Dim txtInsertInto As String: txtInsertInto = "INSERT INTO " & txtテーブル物理名 & " ("
            Dim txtInsertValues As String: txtInsertValues = " VALUES ("
            
            For k = 2 To lngカラム終了列
            
                If k > 2 Then
                    txtInsertInto = txtInsertInto & ", "
                    txtInsertValues = txtInsertValues & ", "
                End If
                
                txtInsertInto = txtInsertInto & .Cells(lngカラム物理名記載行, k)
                txtInsertValues = txtInsertValues & editカラム値(.Cells(j, k), .Cells(lng型桁記載行, k))
            Next k
            
            txt結果 = txt結果 & txtInsertInto & ")" & vbCrLf & "   " & txtInsertValues & ");" & vbCrLf
            
jContinue:
        Next j
        
    End With

    If txt結果 <> "" Then
        txt結果 = vbCrLf & "-- " & txtテーブル論理名 & " " & txtテーブル物理名 & vbCrLf & txt結果
        createInsert文 = txt結果
    End If

End Function

' *********************************************************************************************************************
' 機能：UPDATE文を作成する
' *********************************************************************************************************************
'
Public Function createUpdate文(ByVal is選択行のみ As Boolean) As String

    Dim txt結果 As String
    
    With Me.対象シート
    
        If .Range("B" & lngデータ開始行).Value = "" Then
        
            Exit Function ' データがない場合、UPDATE文の作成はしない
        End If
        
        Dim var主キー As Variant
        var主キー = Me.get主キー()
        
        Dim j, k As Long
        
        ' データ行、1行ごとの処理
        For j = lngデータ開始行 To lngデータ終了行
        
            If .Range("B" & j).Value = "" Then
            
                GoTo jContinue
            End If
            
            If is選択行のみ And Not is選択状態(j) Then ' 選択行のみSQL文作成対象にする場合の考慮
            
                GoTo jContinue
            End If
            
            Dim txtUpdate As String: txtUpdate = "UPDATE " & txtテーブル物理名 & " SET "
            Dim txtWHERE As String: txtWHERE = " WHERE "
            
            For k = 2 To lngカラム終了列
            
                If containArray(var主キー, .Cells(lngカラム物理名記載行, k)) Then
                
                    If txtWHERE <> " WHERE " Then
                    
                        txtWHERE = txtWHERE & " AND "
                    End If
            
                    txtWHERE = txtWHERE & .Cells(lngカラム物理名記載行, k) _
                        & " = " & editカラム値(.Cells(j, k), .Cells(lng型桁記載行, k))
                Else
                    If Not txtUpdate Like "* SET " Then
                    
                        txtUpdate = txtUpdate & " , "
                    End If
                    
                    txtUpdate = txtUpdate & .Cells(lngカラム物理名記載行, k) _
                        & " = " & editカラム値(.Cells(j, k), .Cells(lng型桁記載行, k))
                End If
                
            Next k
            
            txt結果 = txt結果 & txtUpdate & vbCrLf & "   " & txtWHERE & ";" & vbCrLf
            
jContinue:
        Next j
        
    End With

    If txt結果 <> "" Then
        txt結果 = vbCrLf & "-- " & txtテーブル論理名 & " " & txtテーブル物理名 & vbCrLf & txt結果
        createInsert文 = txt結果
    End If

End Function

' *********************************************************************************************************************
' 機能：DELETE文を作成する
' *********************************************************************************************************************
'
Public Function createDelete文(ByVal is選択行のみ As Boolean) As String

    Dim Re As Object: Set Re = CreateObject("VBScript.RegExp")
    Re.Global = True
    Re.Pattern = "SELECT.+? FROM "

    Dim txt結果 As String
    txt結果 = Re.Replace(createSELECT文From複数行To複数SQL(is選択行のみ), "DELETE FROM ")
    
    Re.Pattern = " ORDER BY .+?;"
    createDelete文 = Re.Replace(str結果, ";")

End Function

' *********************************************************************************************************************
' 機能：SELECT文を、COUNTを行うSQLに変更する。
' *********************************************************************************************************************
'
Public Function createCount文(ByVal txtQuery As String) As String

    Dim Re As Object: Set Re = CreateObject("VBScript.RegExp")
    Re.Pattern = "(SELECT .+? FROM)"
    
    createCount文 = Re.Replace(txtQuery, "SELECT COUNT(*) AS COUNT FROM")
    
End Function
' *********************************************************************************************************************
' 機能：枠をクリップボードにコピーする
' *********************************************************************************************************************
'
Public Sub copy枠Toクリップボード()

    ActiveWorkbook.ActiveSheet.Rows(lngテーブル名記載行 & ":" & lngデータ開始行).Copy
    
End Sub


' *********************************************************************************************************************
' 機能：データ行の内容をクリアする
' *********************************************************************************************************************
'
Public Sub clearデータ行()

    Me.対象シート.Rows(lngデータ開始行 & ";" & lngデータ終了行).ClearContents ' 内容をクリア
    Me.対象シート.Rows(lngデータ開始行 & ";" & lngデータ終了行).ClearComments ' コメントをクリア
    
End Sub

' *********************************************************************************************************************
' 機能：引数で指定された自動設定値と同一のカラム名がテーブル内に存在する場合、設定値を1行目にセットする。
' *********************************************************************************************************************
'
Public Sub set抽出条件(ByVal var自動設定値 As Variant)

    With Me.対象シート
    
        Dim i As Long
        For i = 2 To lngカラム終了列
    
            Dim j As Long
            For j = LBound(var自動設定値) To UBound(var自動設定値)
        
                If .Cells(lngカラム物理名記載行, i) = var自動設定値(j, 1) Then
            
                    .Cells(lngカラム物理名記載行, i) = var自動設定値(j, 2)
                
                End If
            Next j
        Next i
    End With
End Sub

' *********************************************************************************************************************
' 機能：指定された行に空行を作成する
' *********************************************************************************************************************
'
Public Sub add空行(ByVal arg追加行番号 As Long)

    Me.対象シート.Rows(lngデータ開始行).Copy  ' データ行の1行目から書式コピー
    Me.対象シート.Rows(arg追加行番号).Insert ' 行追加
    Me.対象シート.Rows(arg追加行番号).ClearContens ' 内容をクリア
    Me.対象シート.Rows(arg追加行番号).ClearComments ' コメントをクリア
    
    Application.CutCopyMode = False
    
End Sub


' *********************************************************************************************************************
' 機能：選択された行を黄色で着色
' *********************************************************************************************************************
'
Public Sub edit選択行協調(ByVal arg選択行番号 As Long)

    With Me.対象シート
    
        Call Me.edit変更強調色(.Range(.Cells(arg選択行番号, 2), .Cells(arg選択行番号, lngカラム終了列)))

    End With

End Sub


' *********************************************************************************************************************
' 機能：選択された行を網掛
' *********************************************************************************************************************
'
Public Sub edit選択行網掛(ByVal arg選択行番号 As Long)

    With Me.対象シート
    
        Call Me.edit網掛(.Range(.Cells(arg選択行番号, 2), .Cells(arg選択行番号, lngカラム終了列)))
        
    End With

End Sub

' *********************************************************************************************************************
' 機能：選択された範囲を網掛け
' *********************************************************************************************************************
'
Public Sub edit変更強調色(ByRef arg修飾範囲 As Range)

    With arg修飾範囲.Interior
        .Pattern = xlGray16
        .PatternColorIndex = xlAutomatic
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

End Sub

' *********************************************************************************************************************
' 機能：指定された主キー項目を連結した文字列を返却する
' *********************************************************************************************************************
'
Function get主キー項目連結文字列(ByVal arg対象データ行 As Long) As String

    get主キー項目連結文字列 = Join(get主キー(lng対象データ行))

End Function

' *********************************************************************************************************************
' 機能：データ行の入力数を返却する。
' *********************************************************************************************************************
'
Private Function getデータ行の入力数(Optional arg対象データ行 = -1)

    With ActiveSheet
    
        If arg対象データ行 = -1 Then
        
            getデータ行の入力数 = WorksheetFunction.CountA( _
                .Range(.Cells(lngデータ開始行, 2), .Cells(lngデータ終了行, lngカラム終了列)))
            
        Else
            
            getデータ行の入力数 = WorksheetFunction.CountA( _
                .Range(.Cells(arg対象データ行, 2), .Cells(arg対象データ行, lngカラム終了列)))
                
        End If
            
    End With

End Function

' *********************************************************************************************************************
' 機能：主キーを配列で返却する
' *********************************************************************************************************************
'
Public Function get主キー(Optional ByVal arg対象データ行 As Long = -1) As Variant

    If arg対象データ行 = -1 Then
        arg対象データ行 = lngカラム物理名記載行
    End If

    Dim var主キー As Variant
    ReDim var主キー(1 To lngカラム終了列) ' 予想され得る最大値＝カラム数で配列を確保
    
    Dim i, lng主キー数 As Long
    
    For i = 2 To lngカラム終了列
    
        With Me.対象シート
        
            ' 主キーカラムであるか否かを、背景色で判断
            ' If .Cells(lngカラム物理名記載行, i).Interior.ThemeColor = xlThemeColorAccent2 Then
            If IsNumeric(.Cells(lng制約記載行, i).Value) Then
                
                lng主キー数 = lng主キー数 + 1
                var主キー(lng主キー数) = .Cells(arg対象データ行, i).Value
                
            End If
        End With
    Next
    
    If lng主キー数 = 0 Then
    
        get主キー = Empty
    Else
    
        ReDim Preserve var主キー(1 To lng主キー数)
        get主キー = var主キー
        
    End If
    
End Function


' *********************************************************************************************************************
' 機能：カラムに対する値を型桁に合わせて加工する(チェック機能付)
' *********************************************************************************************************************
'
Private Function editカラム値( _
    ByVal argカラム値 As String, ByVal arg型桁 As String, Optional ByVal is列名 = False) As String
    
    arg型桁 = UCase(arg型桁)
    
    If argカラム値 = "" Or argカラム値 Like "*(NULL)*" Then
        editカラム値 = "NULL"
        Exit Function
    End If
    
    ' -----------------------------------------------------------------------------------------------------------------
    ' DATE型
    ' -----------------------------------------------------------------------------------------------------------------
    '
    If arg型桁 Like "DATE*" Then
    
        If UCase(argカラム値) = "SYSTIMESTAMP" Or UCase(argカラム値) = "SYSDATE" Then
        
            editカラム値 = argカラム値
        Else
            If is列名 Then
                editカラム値 = "TO_CHAR(" & argカラム値 & ", 'YYYY/MM/DD HH24:MI:SS')"
            Else
                editカラム値 = "TO_DATE('" & argカラム値 & "', 'YYYY/MM/DD HH24:MI:SS')"
            End If
        End If
    
    ' -----------------------------------------------------------------------------------------------------------------
    ' DATE型
    ' -----------------------------------------------------------------------------------------------------------------
    '
    ElseIf arg型桁 Like "TIMESTAMP*" Then
        
        If UCase(argカラム値) = "SYSTIMESTAMP" Or UCase(argカラム値) = "SYSDATE" Then
        
            editカラム値 = argカラム値
        Else
            If is列名 Then
                editカラム値 = "TO_CHAR(" & argカラム値 & ", 'YYYY/MM/DD HH24:MI:SS.FF6')"
            Else
                editカラム値 = "TO_TIMESTAMP('" & argカラム値 & "', 'YYYY/MM/DD HH24:MI:SS.FF6')"
                
            End If
        End If

    ' -----------------------------------------------------------------------------------------------------------------
    ' NUMBER、INT、FLOAT型
    ' -----------------------------------------------------------------------------------------------------------------
    '
    ElseIf arg型桁 Like "NUMBER*" Or arg型桁 Like "INT*" Or arg型桁 Like "FLOAT*" Then
    
        editカラム値 = argカラム値

    ' -----------------------------------------------------------------------------------------------------------------
    ' VARCHAR2,CHAR型
    ' -----------------------------------------------------------------------------------------------------------------
    '
    ElseIf arg型桁 Like "VARCHAR*" Or arg型桁 Like "CHAR*" Then
    
        If is列名 Then
            editカラム値 = argカラム値
        Else
            editカラム値 = "'" & argカラム値 & "'"
        End If
        
    Else
        MsgBox "処理できない型：" & arg型桁
    End If

End Function