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


コメント

アクセス数の多い投稿

セキュリティ対策ソフトのノートンが詐欺ソフトまがいになってしまってショック

NEC Aterm WX5400HP をセットアップ

Windows セキュリティーのビックリマークが消えない

突然滅茶苦茶遅くなったPCがWindows Updateのキャッシュクリアで復活

ChatGPTが日本語からVBAのコードを生成できてたまげる

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

Power Automate Desktopでブラウザでダウンロードしたファイルを処理する

Excel 2019 クエリが原因で日本語入力の一文字目が勝手に確定する

Microsoft Flight Simulator (2020)のPS4コントローラー設定

Amazon Prime Videoで4K UHD映画を検索する方法