VBA：ODBCを使って毎回テーブルを作成するサンプル

 以前、Excel の VBA からODBCを使って簡単にデータを取得する投稿をしました。

Excel VBAからODBCを使ってデータを簡単に取得する

実務で使っているうちに、テーブルのデータをソートしたり、編集したりしていると、データがおかしくなる現象に何度か遭遇しました。

そこで、最近は毎回テーブルを作り直すプログラムも書いています。

毎回作り直すとなると、書式の設定や、列幅の維持などが問題になってきます。

列幅をDictionaryに保存して戻す仕組みや、テーブルの書式設定を行うプロシージャーを書いてみました。

ご参考までに。

Option Explicit

'参照設定 Microsoft Scripting Runtime

Private Const cTABLE_LU_CELL As String = "B4" 'テーブルの左上セル
Private Const cWS_NAME As String = "データ" 'ワークシート名
Private Const cLIST_NAME As String = "データ" 'テーブル名


'請求書データをリフレッシュする
Public Sub uRefleshList()
    Dim uWS As Worksheet
    Dim uList As ListObject
    Dim uDict As Scripting.Dictionary
    Dim uStartCell As Range
    Dim uLastCell As Range
    Dim uT As Double
    
    Application.ScreenUpdating = False
    
    Set uWS = ThisWorkbook.Worksheets(cWS_NAME)
    Set uDict = uSaveColumnWidth(uWS)
    uDeleteDataRows uWS
    Set uList = uCreateTable
    uReflesh uList
    uFormatTable uList
    
    If uDict.Count Then
        uRestoreColumnWidth uWS, uDict
    Else
        Set uStartCell = uWS.Range(cTABLE_LU_CELL)
        Set uLastCell = uWS.Cells.SpecialCells(xlCellTypeLastCell)
        uWS.Range(uStartCell, uLastCell).Columns.AutoFit
    End If
    
    ActiveWindow.ScrollRow = 1
    ActiveSheet.Range("請求日From").Activate
    
    Application.ScreenUpdating = True
End Sub


'テーブルの列幅をDictionaryに保存して返す
Private Function uSaveColumnWidth(ByVal uWS As Worksheet) As Scripting.Dictionary
    Dim uDict As Scripting.Dictionary
    Dim uList As ListObject
    Dim uColumn As ListColumn
    
    Set uDict = New Scripting.Dictionary
    
    For Each uList In uWS.ListObjects
        If uList.Name = cLIST_NAME Then
            For Each uColumn In uList.ListColumns
                With uColumn
                    uDict.Add .Range.Column, .Range.ColumnWidth
                End With
            Next
        End If
    Next
    
    Set uSaveColumnWidth = uDict
End Function


'ワークシートのテーブルを含むデータ行を削除する

'スクロールバーのリセットも兼ねています
Private Sub uDeleteDataRows(ByVal uWS As Worksheet)
    Dim uStartCell As Range
    Dim uLastCell As Range
    
    Set uStartCell = uWS.Range(cTABLE_LU_CELL)
    Set uLastCell = uWS.Cells.SpecialCells(xlCellTypeLastCell)
    uWS.Range(uStartCell, uLastCell).Rows.Delete

End Sub


'テーブル作成

'DSNは適宜環境に合わせて指定してください
Private Function uCreateTable() As ListObject
    Dim uWS As Worksheet
    Dim uList As ListObject
    
    Set uWS = ActiveSheet
    
    Set uList = uWS.ListObjects.Add( _
        SourceType:=xlSrcQuery, _
        Source:="ODBC;DSN=NK", _
        Destination:=Range(cTABLE_LU_CELL))
    
    With uList
        .DisplayName = cLIST_NAME
        .ShowTotals = True
    End With
    
    Set uCreateTable = uList
End Function


'QueryTableをリフレッシュする

'SQLは大幅に削ってあります
Private Sub uReflesh(ByVal uList As ListObject)
    Dim uSQL As String
    Dim uWS As Worksheet
    Dim sIsCondition As Boolean
    
    Set uWS = ThisWorkbook.Worksheets(cWS_NAME)
    
    uSQL = _
        "SELECT " & _
        "    請求日,請求書番号 "
    
    uSQL = uSQL & _
        "FROM " & _
        "    請求 "
    
    uWhere uWS, uSQL
    
    uSQL = uSQL & "GROUP BY 請求先区分,請求先コード,請求書番号 "
    
    If uWS.Range("入金日From") <> "" Or uWS.Range("入金日From") <> "" Then
        uSQL = uSQL & "ORDER BY 入金日,請求日,請求書番号 "
    Else
        uSQL = uSQL & "ORDER BY 請求日,請求書番号,入金日 "
    End If
    
    With uList.QueryTable
        .CommandText = uSQL
        .AdjustColumnWidth = False '列幅調整しない
        
        'Debug.Print uSQL 'ODBCエラー調査用
        .Refresh BackgroundQuery:=False
    End With
End Sub


'WHERE 条件を設定する
Private Sub uWhere(ByVal uWS As Worksheet, ByRef uSQL As String)
    uAddWhereOrAnd "" '初回フラグをクリアして WHEREから開始
    
    If uWS.Range("請求日From") <> "" Then
        uAddWhereOrAnd uSQL
        If uWS.Range("請求日To") <> "" Then
            uSQL = uSQL & "請求日 " & _
                "BETWEEN '" & Format(uWS.Range("請求日From"), "yyyy-mm-dd") & "' " & _
                "AND '" & Format(uWS.Range("請求日To"), "yyyy-mm-dd") & "' "
        Else
            uSQL = uSQL & "請求日 >= '" & Format(uWS.Range("請求日From"), "yyyy-mm-dd") & "' "
        End If
    Else
        If uWS.Range("請求日To") <> "" Then
            uAddWhereOrAnd uSQL
            uSQL = uSQL & "請求日 <= '" & Format(uWS.Range("請求日To"), "yyyy-mm-dd") & "' "
        End If
    End If
    
    If uWS.Range("請求書番号") <> "" Then
        uAddWhereOrAnd uSQL
        uSQL = uSQL & " 請求書番号 like '%" & uWS.Range("請求書番号") & "%' "
    End If
    
    If uWS.Range("請求金額From") <> "" Then
        uAddWhereOrAnd uSQL
        If uWS.Range("請求金額To") <> "" Then
            uSQL = uSQL & "課税費目小計 + 消費税額 + 非課税費目小計 " & _
                "BETWEEN " & uWS.Range("請求金額From") & " " & _
                "AND " & uWS.Range("請求金額To") & " "
        Else
            uSQL = uSQL & "課税費目小計 + 消費税額 + 非課税費目小計" & _
                ">= " & uWS.Range("請求金額From") & " "
        End If
    Else
        If uWS.Range("請求金額To") <> "" Then
            uAddWhereOrAnd uSQL
            uSQL = uSQL & "課税費目小計 + 消費税額 + 非課税費目小計" & _
                "<= " & uWS.Range("請求金額To") & " "
        End If
    End If
End Sub


'WHERE もしくは AND を SQL に追加

'Static変数を使って初回呼び出しとその後の呼び出しを区別しています
Private Sub uAddWhereOrAnd(ByRef uSQL As String)
    Static sIsCondition As Boolean
    

    If uSQL = "" Then
        sIsCondition = False
        Exit Sub
    End If
    
    If sIsCondition Then
        uSQL = uSQL & "AND "
    Else
        uSQL = uSQL & "WHERE "
        sIsCondition = True
    End If
End Sub


'テーブルをフォーマット
Private Sub uFormatTable(ByVal uList As ListObject)
    Dim uFC As FormatCondition
    Dim uWS As Worksheet
    
    Set uWS = uList.Parent
    
    With uList
        If .ListRows.Count Then 'テーブルデータが存在しない場合の対策
            .ListColumns("請求日").DataBodyRange.NumberFormatLocal = "yyyy/mm/dd"
            .ListColumns("請求金額").DataBodyRange.NumberFormatLocal = "#,##0;[赤]-#,##0"
            .ListColumns("入金日").DataBodyRange.NumberFormatLocal = "yyyy/mm/dd"
            .ListColumns("回収高").DataBodyRange.NumberFormatLocal = "#,##0;[赤]-#,##0"
            

            '請求日からの経過日数によってセルの色を変える
            With .ListColumns("請求日").DataBodyRange
                Set uFC = .FormatConditions.Add(xlExpression, , _
                    "=TODAY() - INDIRECT(""" & cLIST_NAME & "[@請求日]"") > 360")
                uFC.Interior.Color = 5263615 'Red

                Set uFC = .FormatConditions.Add(xlExpression, , _
                    "=TODAY() - INDIRECT(""" & cLIST_NAME & "[@請求日]"") > 270")
                uFC.Interior.Color = 13408767 'Pink

                Set uFC = .FormatConditions.Add(xlExpression, , _
                    "=TODAY() - INDIRECT(""" & cLIST_NAME & "[@請求日]"") > 180")
                uFC.Interior.Color = 6737151 'Orange

                Set uFC = .FormatConditions.Add(xlExpression, , _
                    "=TODAY() - INDIRECT(""" & cLIST_NAME & "[@請求日]"") > 90")
                uFC.Interior.Color = 10092543 'Yellow
            End With
            
            
            With .ListColumns("ステータス").DataBodyRange
                Set uFC = .FormatConditions.Add(xlCellValue, xlEqual, "仮請求")
                uFC.Interior.Color = vbYellow
            End With
        End If
        
        .ListColumns("請求金額").TotalsCalculation = xlTotalsCalculationSum
        .ListColumns("回収高").TotalsCalculation = xlTotalsCalculationSum
        .ListColumns("請求").TotalsCalculation = xlTotalsCalculationNone
    End With
End Sub


'Dictionaryに保存されている列幅を復元する
Private Sub uRestoreColumnWidth( _
    ByVal uWS As Worksheet, _
    ByVal uDict As Scripting.Dictionary)
    
    Dim uKey As Variant
    
    For Each uKey In uDict
        uWS.Columns(uKey).ColumnWidth = uDict(uKey)
    Next
End Sub