スクリプト置き場

Option Explicit
Private tableList As Collection
Private Const RESULT_SHEET_NAME = "SQL実行結果"
Private Const SHEET_TABLE_SHOW = False
Private Const NAME_TABLE_SHOW = True

' フォームの初期化処理
Private Sub UserForm_Initialize()
    Set tableList = New Collection
    RefreshButton_Click
End Sub

' リフレッシュボタンが押された時の処理
Private Sub RefreshButton_Click()
    Dim bookName As String
    Dim tableName As String
    Dim fieldName As String
    Dim lstIndex As Integer
    Dim book As Workbook
    
    ' 現在のブック名を取得
    lstIndex = bookNameCombo.ListIndex
    If (lstIndex <> -1) Then
        bookName = bookNameCombo.List(lstIndex)
    End If
    
    ' 現在のテーブル名を取得
    lstIndex = tableNameList.ListIndex
    If (lstIndex <> -1) Then
        tableName = tableNameList.List(lstIndex)
    End If

' 現在のフィールド名を取得
    lstIndex = fieldNameList.ListIndex
    If (lstIndex <> -1) Then
        fieldName = fieldNameList.List(lstIndex)
    End If
    
    ' ブック名コンボボックスを更新
    bookName = RefreshBookNameCombo(bookName)
    
    ' テーブル名リストボックスを更新
    tableName = RefreshTableNameList(Workbooks(bookName), tableName)
    
    ' フィールド名リストボックスを更新
    fieldName = RefreshFeldNameList(tableName, fieldName)
    
End Sub

' ブック名コンボボックスをリフレッシュ(initNameがあればそれを選択、無ければ最初のブックを選択)
Private Function RefreshBookNameCombo(initName As String) As String
    Dim index As Integer
    Dim comboIndex As Integer
    Dim book As Workbook
    comboIndex = 0
    index = 0
    
    ' コンボボックスをクリアし、ブック名を追加
    bookNameCombo.Clear
    For Each book In Workbooks
        
        ' 指定された名前と同じブックがあればインデックスを保存
        If (book.name = initName) Then
            comboIndex = index
        End If
        
        bookNameCombo.AddItem book.name
        index = index + 1
    Next
    
    ' コンボボックスの選択項目を設定
    bookNameCombo.ListIndex = comboIndex
    
    ' 選択された項目名を返す
    RefreshBookNameCombo = bookNameCombo.List(comboIndex)
    
End Function

' テーブル名リストをリフレッシュ(initNameがあればそれを選択、無ければ最初のテーブルを選択)
Private Function RefreshTableNameList(book As Workbook, initName As String) As String
    Dim index As Integer
    Dim lstIndex As Integer
    Dim item As TableInfo
    lstIndex = 0
    index = 0
    
    ' 指定されたワークブックからテーブル情報を取得
    removeTableList
    AddTablesFromWorkbook tableList, book
    
    ' リストボックスをクリアし、テーブル名を追加
    tableNameList.Clear
    For Each item In tableList
    
        ' 表示対象ではないテーブルは追加しない
        If (IsTableEnable(item)) Then
                
            tableNameList.AddItem item.name
            
            ' 指定された名前と同じテーブルがあればインデックスを保存
            If (item.name = initName) Then
                lstIndex = index
            End If
            
            index = index + 1
        End If
    Next
    
    ' リストボックスの選択項目を設定
    tableNameList.ListIndex = lstIndex
    
    ' 選択された項目名を返す
    RefreshTableNameList = tableNameList.List(lstIndex)
    
End Function

' テーブル情報が有効かどうかを返す
Function IsTableEnable(tInfo As TableInfo) As Boolean
    If ((tInfo.tableType = TABLE_TYPE_NAME) And SHEET_TABLE_SHOW) Then
        IsTableEnable = True
    ElseIf ((tInfo.tableType = TABLE_TYPE_NAME) And NAME_TABLE_SHOW) Then
        IsTableEnable = True
    Else
        IsTableEnable = False
    End If
End Function

' フィールド名リストをリフレッシュ(initNameがあればそれを選択、無ければ最初のテーブルを選択)
Private Function RefreshFeldNameList(tableName As String, initName As String) As String
    Dim index As Integer
    Dim lstIndex As Integer
    Dim item As Variant
    Dim tInfo As TableInfo
    Dim isExist As Boolean
    lstIndex = 0
    index = 0
    isExist = False
    
    ' テーブルリストから指定されたテーブル情報を取得
    For Each item In tableList
        Set tInfo = item
        If (tInfo.name = tableName) Then
            isExist = True
            Exit For
        End If
    Next
    
    ' テーブル名が存在しない場合はメッセージを表示して中断
    If (Not isExist) Then
        log LEVEL_WARNING, "フィールド名リフレッシュ時にテーブル情報の取得失敗。"
        MsgBox "選択されているテーブル情報が見つかりませんでした。", vbOKOnly & vbExclamation, "WARNING"
        Exit Function
    End If
    
    ' リストボックスをクリアし、テーブル名を追加
    fieldNameList.Clear
    For Each item In tInfo.fieldNames
        fieldNameList.AddItem item
        
        ' 指定された名前と同じテーブルがあればインデックスを保存
        If (item = initName) Then
            lstIndex = index
        End If
        
        index = index + 1
    Next
    
    ' リストボックスの選択項目を設定
    fieldNameList.ListIndex = lstIndex
    
    ' 選択された項目名を返す
    RefreshFeldNameList = fieldNameList.List(lstIndex)
    
End Function

' ブック名が選択されたときの処理
Private Sub bookNameCombo_Change()
    Dim bookName As String
    Dim lstIndex As Integer
    
    ' 未選択状態の場合は処理を行わない
    lstIndex = bookNameCombo.ListIndex
    If (lstIndex = -1) Then
        Exit Sub
    End If
    
    ' 選択されたブック名を使用してテーブル情報を更新
    bookName = bookNameCombo.List(lstIndex)
    RefreshTableNameList Workbooks(bookName), vbNullString
    
End Sub

' テーブル名リストボックスがクリックされた時の処理
Private Sub tableNameList_Click()
    Dim tableName As String
    Dim lstIndex As Integer
    
    ' 未選択状態の場合は処理を行わない
    lstIndex = tableNameList.ListIndex
    If (lstIndex = -1) Then
        Exit Sub
    End If
    
    ' フィールド名リストボックスを更新
    tableName = tableNameList.List(tableNameList.ListIndex)
    RefreshFeldNameList tableName, vbNullString
    
End Sub

' テーブル名リストがダブルクリックされた時の処理
Private Sub tableNameList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    tableInsertButton_Click
End Sub

' フィールド名リストボックスがダブルクリックされたときの処理
Private Sub fieldNameList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    fieldInsertButton_Click
End Sub

' テーブルの挿入ボタンが押された時の処理
Private Sub tableInsertButton_Click()
    Dim tableName As String
    Dim lstIndex As Integer
    Dim text As String
    
    ' 未選択状態の場合は処理を行わない
    lstIndex = tableNameList.ListIndex
    If (lstIndex = -1) Then
        Exit Sub
    End If
    
    ' テーブル名にスペースが含まれる場合は[]で囲む
    tableName = tableNameList.List(tableNameList.ListIndex)
    If (InStr(tableName, " ") <> 0) Then
        tableName = "[" & tableName & "]"
    End If
    
    ' テーブル名ををテキストに追加
    With sqlCommandText
        .text = Left$(.text, .SelStart + 1) & tableName & Mid$(.text, .SelStart + 1)
    End With
End Sub

' フィールドの挿入ボタンが押された時の処理
Private Sub fieldInsertButton_Click()
    Dim fieldName As String
    Dim lstIndex As Integer
    Dim text As String
    
    ' 未選択状態の場合は処理を行わない
    lstIndex = fieldNameList.ListIndex
    If (lstIndex = -1) Then
        Exit Sub
    End If
    
    ' フィールド名にスペースが含まれている場合は[]で囲む
    fieldName = fieldNameList.List(fieldNameList.ListIndex)
    If (InStr(fieldName, " ") <> 0) Then
        fieldName = "[" & fieldName & "]"
    End If
    
    ' フィールド名ををテキストに追加
    With sqlCommandText
        .text = Left$(.text, .SelStart + 1) & fieldName & ", " & Mid$(.text, .SelStart + 1)
    End With

End Sub

' 表示ボタンがクリックされた時の処理
Private Sub tableShowButton_Click()
    Dim isExist As Boolean
    Dim item As TableInfo
    Dim tInfo As TableInfo
    Dim tableName As String
    Dim lstIndex As Integer
    isExist = False
    
    ' テーブル名リストが選択されていない場合は処理を中断
    lstIndex = tableNameList.ListIndex
    If (lstIndex = -1) Then
        Exit Sub
    End If
    
    ' テーブルリストから指定されたテーブル情報を取得
    tableName = tableNameList.List(lstIndex)
    For Each item In tableList
        If (item.name = tableName) Then
            isExist = True
            Set tInfo = item
            Exit For
        End If
    Next
    
    ' テーブル情報が見つからない場合はメッセージを表示して中断
    If (Not isExist) Then
        log LEVEL_WARNING, "表示ボタン押下時にテーブル情報の取得失敗。"
        MsgBox "選択されているテーブル情報が見つかりませんでした。", vbOKOnly & vbExclamation, "WARNING"
        Exit Sub
    End If
            
    ' 選択されている領域をアクティブにする
    tInfo.position.Parent.Activate
    tInfo.position.Activate
    
End Sub

' SQL実行ボタンが押された時の処理
Private Sub sqlExecuteButton_Click()
    Dim book As Workbook
    Dim sheet As Worksheet
    Dim rng As Range
    Dim retError As String
    
    ' 出力結果シートがない場合は作成する
    If (Not sheetExist(ActiveWorkbook, RESULT_SHEET_NAME)) Then
        Dim newSheet As Worksheet
        Set newSheet = ActiveWorkbook.Sheets.Add
        newSheet.name = RESULT_SHEET_NAME
    End If
    
    ' SQLを実行する
    Set sheet = ActiveWorkbook.Sheets(RESULT_SHEET_NAME)
    Set rng = sheet.Cells(1, 1)
    Set book = Workbooks(bookNameCombo.List(bookNameCombo.ListIndex))
    sheet.Cells.Clear
    retError = executeSQL(book, sqlCommandText, rng)
    
    '実行に失敗した場合はエラーを表示
    If (LenB(retError) <> 0) Then
        MsgBox retError, vbCritical & vbOKOnly, "ERROR"
    End If
    
    ' コピー先のシートをアクティブにする
    sheet.Activate
    
End Sub

' 終了ボタンが押された時の処理
Private Sub exitButton_Click()
    Unload Me
End Sub

' シートの存在を確認
Private Function sheetExist(book As Workbook, sheetName As String) As Boolean
    On Error GoTo ERR_HANDLE
    Dim sheet As Worksheet
    Set sheet = book.Sheets(sheetName)
    sheetExist = True
    Exit Function
ERR_HANDLE:
    sheetExist = False
End Function

' テーブルリストを全削除する
Private Sub removeTableList()
    Dim item As Variant
    For Each item In tableList
        tableList.Remove 1
    Next
End Sub

Excel表をSQLで操作