#VBA100本ノック 96本目

VBA Excel

エクセルの神髄 の中の人がツイッターで行っている VBA100本ノック の96本目の解答記事です。

自分が見た範囲の解答ではADODB.Commandによるパラメータ挿入を使っている例を見なかったので、自身の確認も兼ねての解答です。

Public Sub VBA100Knock66()
    '配布されているデータを、同じ場所に保存している前提です。
        'https://twitter.com/yamaoka_ss/status/1365174893566849025
    Dim dbFullName As String
    dbFullName = ThisWorkbook.Path & "\DB1.accdb"
    
    '出力先を事前にきれいにしておきます。
    Dim outputSheet As Excel.Worksheet
    Set outputSheet = ThisWorkbook.Worksheets.Item(1)
    outputSheet.Cells.Delete
    
    
'ADODB の接続部分の設定。
    Dim conn As ADODB.Connection
    Set conn = VBA.Interaction.CreateObject("ADODB.Connection")
    conn.Provider = "Microsoft.ACE.OLEDB.16.0"
    With conn.Properties
        .Item("Data Source").Value = dbFullName
        .Item("Extended Properties").Value = GuessIsamType(dbFullName) & ";"
    End With
    
    conn.Open
    
'ADODB.Command で SQL を設定する。
    Dim cmd As ADODB.Command
    Set cmd = VBA.Interaction.CreateObject("ADODB.Command")
    Set cmd.ActiveConnection = conn
    cmd.CommandType = adCmdText
    
    Dim sqlCmd As String
    sqlCmd = _
        "SELECT " & _
            "[T売上].[取引先CD], " & _
            "[M取引先].[取引先名], " & _
            "[T売上].[商品CD], " & _
            "[M商品].[商品名], " & _
            "[T売上].[単価], " & _
            "[T売上].[数量], " & _
            "[T売上].[単価] * [T売上].[数量] AS [金額]" & _
        "FROM (" & _
            "([T売上] LEFT JOIN [M取引先] ON [T売上].[取引先CD] = [M取引先].[取引先CD]) " & _
                "LEFT JOIN [M商品] ON [T売上].[商品CD] = [M商品].[商品CD]" & _
            ")" & _
        "WHERE " & _
            "[T売上].[日付] >= [以降を抽出したい売上日] AND " & _
            "[T売上].[単価] * [T売上].[数量] >= [最低金額]"
    cmd.CommandText = sqlCmd
    
    'https://twitter.com/yamaoka_ss/status/1365174782161952775
    '■抽出条件
        '2021年以降(2021/01/01～)
        '金額が100万以上
    cmd.Parameters.Append cmd.CreateParameter("以降を抽出したい売上日", adDate, Value:=VBA.DateTime.DateSerial(2021, 1, 1))
    cmd.Parameters.Append cmd.CreateParameter("最低金額", adInteger, Value:=10 ^ 6)
    
    Dim rs As ADODB.Recordset
    Set rs = cmd.Execute()
    
'Excel へ出力する用に各種情報を取得。
    Dim headerNames() As Variant
    ReDim headerNames(0 To rs.Fields.Count - 1)
    Dim i As Long
    i = LBound(headerNames)
    Dim f As ADODB.Field
    For Each f In rs.Fields
        headerNames(i) = f.Name
        i = i + 1
    Next f
    
    Dim dbData() As Variant
    dbData = outputSheet.Application.WorksheetFunction.Transpose(rs.GetRows(Fields:=headerNames))
    
'ここで DB との接続は切っておく。
    rs.Close
    conn.Close
    
    
'Excel にテーブルとして出力。
    With outputSheet.ListObjects.Add(xlSrcRange, outputSheet.Cells.Item(1))
        .HeaderRowRange.Resize(, UBound(headerNames) - LBound(headerNames) + 1).Value() = headerNames
        
        .HeaderRowRange.Offset(1).Resize(UBound(dbData, 1) - LBound(dbData, 1) + 1) = dbData
        
        .Range.Columns.AutoFit
    End With
End Sub


'ファイルの拡張子から、ISAM 形式を類推する(簡易版)。
Private Function GuessIsamType(ByVal inFileName As String) As String
    Dim dotPos As Long
    dotPos = VBA.Strings.InStrRev(inFileName, ".")
    If dotPos = 0 Then Exit Function
    
    Dim ext As String
    ext = VBA.Strings.LCase$(VBA.Strings.Mid$(inFileName, dotPos + 1))
    Select Case ext
        Case "accdb": Let GuessIsamType = ""
        Case "xlsx": Let GuessIsamType = "Excel 12.0 Xml"
    End Select
End Function