和風スパゲティのレシピ

日本語でコーディングするExcelVBA

トップ > 100本ノック > 96本目：Accessデータを取得（マスタ結合&抽出）

96本目：Accessデータを取得（マスタ結合&抽出）

100本ノック VBA

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：Accessデータを取得（マスタ結合&抽出）

DB1.accdbから以下の出力項目と抽出条件でデータを取得しシートに出力する。
■出力項目
取引先CD,取引先名,商品CD,商品名,単価,数量,金額
金額は単価*数量
■抽出条件
2021年以降(2021/01/01～)
金額が100万以上
※テーブルは画像とサンプルにて
※シートは任意

抽出するAccessデータ

◇ 出題ページはこちら

ソースコード

モジュール一覧

Df_データ抽出

Option Explicit

' データ抽出
' (※1)に数式あり
Public Const R1stデータ抽出 = 2
Public Const C1stデータ抽出 = 1
Public Enum CNoデータ抽出
    取引先CD = C1stデータ抽出
    取引先名
    商品CD
    商品名
    日付
    単価
    数量
    金額
End Enum
Public Const CLastデータ抽出 = CNoデータ抽出.金額

' T売上
' (※2)に数式あり
Public Const R1stT売上 = 2
Public Const C1stT売上 = 1
Public Enum CNoT売上
    ID = C1stT売上
    取引先CD
    商品CD
    日付
    単価
    数量
    追加_金額
End Enum
Public Const CLastT売上 = CNoT売上.追加_金額

' M取引先
Public Const R1stM取引先 = 2
Public Const C1stM取引先 = 1
Public Enum CNoM取引先
    取引先CD = C1stM取引先
    取引先名
End Enum
Public Const CLastM取引先 = CNoM取引先.取引先名

' M商品
Public Const R1stM商品 = 2
Public Const C1stM商品 = 1
Public Enum CNoM商品
    商品CD = C1stM商品
    商品名
    標準単価
End Enum
Public Const CLastM商品 = CNoM商品.標準単価

Op_実行モジュール

Option Explicit

' 実行プロシージャ
Sub ★各Accessテーブルを最新に更新してグループ集計を実行する()

    Call エクセルの自動更新を停止する(False)
    
    Call 各テーブルをAccessファイルから読み込む
    Call データ抽出シートを更新する
    
    Call エクセルの自動更新を開始する

    MsgBox "Accessデータの読込とグループ集計を完了しました。"

End Sub

Pr1_Accessデータの取込

Option Explicit

Sub 各テーブルをAccessファイルから読み込む()

    ' 各シートを初期化
    Call 指定行より下をすべて削除する(WS_T売上, R1stT売上)
    Call 指定行より下をすべて削除する(WS_M取引先, R1stM取引先)
    Call 指定行より下をすべて削除する(WS_M商品, R1stM商品)

    ' Accessファイルから各テーブルを読込
    Dim Accessファイルパス As String
    Accessファイルパス = ThisWorkbook.Path & "\DB1.accdb"
    Call Accessの指定テーブルをセルに出力する(Accessファイルパス, "T売上", WS_T売上.Cells(R1stT売上, 1), False)
    Call Accessの指定テーブルをセルに出力する(Accessファイルパス, "M取引先", WS_M取引先.Cells(R1stM取引先, 1), False)
    Call Accessの指定テーブルをセルに出力する(Accessファイルパス, "M商品", WS_M商品.Cells(R1stM商品, 1), False)

End Sub

Pr2_データ抽出

Option Explicit

Const 売上年条件 = 2021
Const 金額条件 = 1000000

' データ抽出の実行
Sub データ抽出シートを更新する()
    
    ' データ抽出シートを初期化
    Call 指定行より下をすべて削除する(WSデータ抽出, R1stデータ抽出)
    
    ' T売上に金額列を追加
    Call T売上データに金額列を追加する
    
    ' 該当データの抽出
    Call T売上シートから条件を満たすデータをデータ抽出シートへ出力する

    ' 各種数式計算
    Call 取引先マスタと商品マスタを参照する
    
End Sub

' 該当データの抽出
Sub T売上シートから条件を満たすデータをデータ抽出シートへ出力する()

    Dim Dic抽出データ As New Dictionary
    Dim Arr抽出データ各行(1 To CLastデータ抽出)
    
    Dim R As Long
    For R = R1stT売上 To Get最終行(WS_T売上)

        If Year(WS_T売上.Cells(R, CNoT売上.日付)) >= 売上年条件 _
        And WS_T売上.Cells(R, CNoT売上.追加_金額) >= 金額条件 Then
            
            Erase Arr抽出データ各行
            Arr抽出データ各行(CNoデータ抽出.取引先CD) = WS_T売上.Cells(R, CNoT売上.取引先CD)
            Arr抽出データ各行(CNoデータ抽出.商品CD) = WS_T売上.Cells(R, CNoT売上.商品CD)
            Arr抽出データ各行(CNoデータ抽出.日付) = WS_T売上.Cells(R, CNoT売上.日付)
            Arr抽出データ各行(CNoデータ抽出.単価) = WS_T売上.Cells(R, CNoT売上.単価)
            Arr抽出データ各行(CNoデータ抽出.数量) = WS_T売上.Cells(R, CNoT売上.数量)
            Arr抽出データ各行(CNoデータ抽出.金額) = WS_T売上.Cells(R, CNoT売上.追加_金額)
            
            Dic抽出データ.Add R, Arr抽出データ各行
            
        End If
        
    Next
    
    Call Itemが一次元配列のDictionaryをセルに出力する _
        (WSデータ抽出.Cells(R1stデータ抽出, 1), Dic抽出データ)

End Sub

' 金額列の追加(※2)
Sub T売上データに金額列を追加する()
    
    Call シート数式で計算する(GetRange指定列のデータ部分(WS_T売上, CNoT売上.追加_金額) _
                                        , "=E2*F2")
    
End Sub

' マスタの参照(※1)
Sub 取引先マスタと商品マスタを参照する()

    Call シート数式で計算する(GetRange指定列のデータ部分(WSデータ抽出, CNoデータ抽出.取引先名) _
                                        , "=VLOOKUP(A2,M取引先!A:B,2,FALSE)")

    Call シート数式で計算する(GetRange指定列のデータ部分(WSデータ抽出, CNoデータ抽出.商品名) _
                                        , "=VLOOKUP($C2,M商品!$A:$C,2,FALSE)")

End Sub

Ut_汎用関数

Option Explicit

' Accessテーブルの取込
Sub Accessの指定テーブルをセルに出力する(Accessファイルパス As String, テーブル名 As String _
    , 出力起点セル As Range, is見出しも出力する As Boolean)
    
    Dim 接続 As Object: Set 接続 = CreateObject("ADODB.Connection")
    接続.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Accessファイルパス & ";"
    
    Dim レコードセット As Object: Set レコードセット = CreateObject("ADODB.Recordset")
    レコードセット.Open "SELECT * FROM " & テーブル名, 接続
    
    ' フィールド名を第1行に出力
    If is見出しも出力する Then
        Dim C As Long
        For C = 1 To レコードセット.Fields.Count
            出力起点セル.Cells(1, C).Value = レコードセット.Fields(C - 1).Name
        Next
    End If
        
    ' 第2行以降に全レコードを出力
    出力起点セル.Cells(IIf(is見出しも出力する, 2, 1), 1).CopyFromRecordset レコードセット
    
    レコードセット.Close: Set レコードセット = Nothing
    接続.Close: Set 接続 = Nothing
    
End Sub

' 指定行より下の削除
Sub 指定行より下をすべて削除する(指定シート As Worksheet, 指定行 As Long)
    With 指定シート
        指定シート.Rows(指定行).Resize(.UsedRange.Rows.Count).Delete
    End With
End Sub

' 最終行の取得
Function Get最終行(指定オブジェクト As Variant, Optional ByVal C As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select
    
    ' エリアの最終行を取得
    Get最終行 = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1
    
    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(Get最終行, C) = ""
            Get最終行 = Get最終行 - 1
            If Get最終行 < 対象セル範囲.Row Then
                Get最終行 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 最終列の取得
Function Get最終列(指定オブジェクト As Variant, Optional ByVal R As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select
    
    ' エリアの最終列を取得
    Get最終列 = 対象セル範囲.Columns.Count + 対象セル範囲.Column - 1
    
    ' 列が指定されていればその列の入力最終行を取得
    If R <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(R, Get最終列) = ""
            Get最終列 = Get最終列 - 1
            If Get最終列 < 対象セル範囲.Column Then
                Get最終列 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 行番号の検索
Function Match行番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Dim x: x = CDbl(検索値)
        If Err.Number = 0 Then
            Match行番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Row - 1
            Exit Function
        End If
    End If

    Match行番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Row - 1
    
End Function

' 列番号の検索
Function Match列番号(ByVal 検索値 As Variant, 検索エリア As Range) As Long
    On Error Resume Next
    If IsDate(検索値) Then
        Match列番号 = Fx.Match(CDbl(検索値), 検索エリア, 0) + 検索エリア.Column - 1
    Else
        Match列番号 = Fx.Match(検索値, 検索エリア, 0) + 検索エリア.Column - 1
    End If
End Function

' データ件数
Function Countデータ件数(対象シート As Worksheet) As Long
    If 対象シート.AutoFilterMode = False Then Exit Function
    With 対象シート.AutoFilter.Range
        Countデータ件数 = .Rows.Count + .Row - 2
    End With
End Function

' 各列のデータ部分
Function GetRange指定列のデータ部分(対象シート As Worksheet, 対象列 As Long) As Range
    If Countデータ件数(対象シート) = 0 Then Exit Function
    Set GetRange指定列のデータ部分 = 対象シート.Cells(対象シート.AutoFilter.Range.Row + 1, 対象列) _
                                                            .Resize(Countデータ件数(対象シート))
End Function

' シート数式計算
Sub シート数式で計算する(計算エリア As Range, シート数式 As String)
    計算エリア.Formula = シート数式
    計算エリア.Value = 計算エリア.Value
End Sub

' 文字列検索切り出しLeft/Right/Mid
Function Left文字列まで(ByVal 元テキスト As String, ByVal 検索値 As String _
    , Optional is検索値を結果に含む As Boolean = False) As String
    
    Dim instr位置 As Long: instr位置 = InStr(元テキスト, 検索値)
    If instr位置 > 0 Then
        Left文字列まで = Left(元テキスト, instr位置 - 1) & IIf(is検索値を結果に含む, 検索値, "")
    End If
    
End Function
Function Right文字列まで(ByVal 元テキスト As String, ByVal 検索値 As String _
    , Optional is検索値を結果に含む As Boolean = False) As String
    
    Dim instrRev位置 As Long: instrRev位置 = InStrRev(元テキスト, 検索値)
    If instrRev位置 > 0 Then
        Right文字列まで = IIf(is検索値を結果に含む, 検索値, "") _
                                          & Mid(元テキスト, instrRev位置 + Len(検索値))
    End If
    
End Function
Function Mid文字列から文字列(ByVal 元テキスト As String, ByVal 前検索値 As String, ByVal 後検索値 As String _
    , Optional is前検索値を結果に含む As Boolean = False, Optional is後検索値を結果に含む As Boolean = False) As String
    
    Dim instr前値 As Long: instr前値 = InStr(元テキスト, 前検索値)
    If instr前値 = 0 Then Exit Function
    
    Dim instr後値 As Long: instr後値 = InStr(instr前値 + Len(前検索値) + 1, 元テキスト, 後検索値)
    If instr後値 = 0 Then Exit Function
    
    Mid文字列から文字列 = _
        IIf(is前検索値を結果に含む, 前検索値, "") & _
        Mid(元テキスト, instr前値 + Len(前検索値), instr後値 - instr前値 - Len(前検索値)) & _
        IIf(is後検索値を結果に含む, 後検索値, "")
        
End Function

' Dictionaryを新規シートに出力する
Sub Dictionaryを新規シートに出力する(Dic As Dictionary)
    With Workbooks.Add.Worksheets(1)
        Call 配列をセルに出力する(.Range("A1"), Dic.Keys)
        Call 配列をセルに出力する(.Range("B1"), Dic.Items)
    End With
End Sub

' 1次元配列 → セル
Sub 配列をセルに出力する(出力始点セル As Range, Arr出力配列 As Variant _
    , Optional is行方向へ出力 As Boolean = True)

    If UBound(Arr出力配列) = -1 Then Exit Sub

    ' ◇ 要素数が1ならば単セルに出力
    If Count配列の要素数(Arr出力配列) = 1 Then
        出力始点セル.Value = Arr出力配列(0)
    
    ' Transposeで方向指定して出力
    ElseIf is行方向へ出力 Then
        出力始点セル.Resize(Count配列の要素数(Arr出力配列), 1) = Fx.Transpose(Arr出力配列)
    Else
        出力始点セル.Resize(1, Count配列の要素数(Arr出力配列)) = Fx.Transpose(Fx.Transpose(Arr出力配列))
    End If
    
End Sub

' 配列を新規シートに出力する
Sub 配列を新規シートに出力する(Arr)
    Workbooks.Add.Worksheets(1).Range("A1") _
        .Resize(Count配列の要素数(Arr, 1), Count配列の要素数(Arr, 2)) = Arr
End Sub

' 配列の要素数の取得
Function Count配列の要素数(Arr, Optional 次元 = 1) As Long
    Count配列の要素数 = UBound(Arr, 次元) - LBound(Arr, 次元) + 1
End Function

' 二次元配列←ジャグ配列
Function GetArr二次元配列←ジャグ配列(Arrジャグ配列 As Variant) As Variant
    
    Dim i As Long, j As Long ' ジャグ配列のインデックス
    Dim R As Long, C As Long ' 二次元配列のインデックス

    Dim Arr出力配列()

    Dim 最大要素数 As Long: 最大要素数 = 0

    ' 配列内の配列の中で最も大きい要素数を取得
    For i = LBound(Arrジャグ配列) To UBound(Arrジャグ配列)
        
        Dim 現要素数 As Long: 現要素数 = Count配列の要素数(Arrジャグ配列(i))
        If 現要素数 >= 最大要素数 Then 最大要素数 = 現要素数

    Next
    
    ' 出力二次元配列を準備
    ReDim Arr出力配列(1 To Count配列の要素数(Arrジャグ配列), 1 To 最大要素数)
    
    ' 全要素を代入
    R = 1
    For i = LBound(Arrジャグ配列) To UBound(Arrジャグ配列)
        C = 1
        For j = LBound(Arrジャグ配列(i)) To UBound(Arrジャグ配列(i))
            
            Arr出力配列(R, C) = Arrジャグ配列(i)(j)
            
            C = C + 1
        Next
        R = R + 1
    Next
    
    GetArr二次元配列←ジャグ配列 = Arr出力配列

End Function

' Dictionary(Item:配列) → セル
Sub Itemが一次元配列のDictionaryをセルに出力する(出力始点セル As Range, Dic As Dictionary)
    
    Dim Arr: Arr = GetArr二次元配列←ジャグ配列(Dic.Items)
    Call 二次元配列をセルに出力する(出力始点セル, Arr)
    
End Sub

' 二次元配列 → セル
Sub 二次元配列をセルに出力する(出力始点セル As Range, Arr出力配列 As Variant)

    出力始点セル.Resize(Count配列の要素数(Arr出力配列, 1) _
                              , Count配列の要素数(Arr出力配列, 2)).Value = Arr出力配列

End Sub

' 配列の次元数の取得
' 参考：https://www.limecode.jp/entry/utility/get-array-dimension
Function Get配列の次元数(Arr As Variant) As Long

    ' 渡された変数が配列ではない場合は0を返すこととする
    If IsArray(Arr) = False Then Get配列の次元数 = 0: Exit Function

    ' エラーが出るまでUBoundを取得してみる
    Dim tmp
    Dim 次元数 As Long: 次元数 = 0
    On Error Resume Next
    Do While Err.Number = 0
        次元数 = 次元数 + 1
        tmp = UBound(Arr, 次元数)
    Loop
    On Error GoTo 0

    ' エラーが出たひとつ前の次元が求める次元数
    Get配列の次元数 = 次元数 - 1
    
End Function

' セルのリストを1次元配列に
' 参考：https://www.limecode.jp/entry/utility/getarray-from-rangeobject
Function GetArrayセルのリストを1次元配列に変換する(セルリスト As Range) As Variant

    ' ◇ 単セル → 値そのまま
    If セルリスト.Cells.Count = 1 Then
        GetArrayセルのリストを1次元配列に変換する = Array(セルリスト.Value)
        Exit Function
    End If

    ' 1列データの時はTransposeで高速化
    If セルリスト.Areas.Count = 1 And セルリスト.Columns.Count = 1 And セルリスト.Count <= 65535 Then
        GetArrayセルのリストを1次元配列に変換する = Fx.Transpose(セルリスト)
        Exit Function
    End If

    ' それ以外は1セルずつ値を格納
    Dim Arr生成配列() As Variant
    ReDim Arr生成配列(1 To セルリスト.Cells.Count) As Variant
    
    Dim i As Long: i = 1
    Dim Cell As Range
    For Each Cell In セルリスト.Cells
        Arr生成配列(i) = Cell.Value
        i = i + 1
    Next

    GetArrayセルのリストを1次元配列に変換する = Arr生成配列

End Function

' WorksheetFunctionの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-worksheetfunction
Function Fx() As WorksheetFunction
    Set Fx = WorksheetFunction
End Function

' QueryTableによるWEB読み込みの汎用関数
' 参考：https://www.limecode.jp/entry/utility/querytables-import-web-table
Sub QueryTableでWEB上の表を読み込む(出力起点セル As Range _
    , 対象URL As String, Optional テーブルNo As Long = -1 _
    , Optional is書式リンク含む As Boolean = False, Optional is日付に変換する As Boolean = False)

    With 出力起点セル.Worksheet.QueryTables.Add("URL;" & 対象URL, 出力起点セル)
    
        If テーブルNo = -1 Then ' テーブルNo省略時は全テーブルを対象
            .WebSelectionType = xlAllTables
        Else
            .WebTables = xlSpecifiedTables
            .WebTables = テーブルNo
        End If
        .WebFormatting = IIf(is書式リンク含む, xlWebFormattingAll, xlWebFormattingNone)
        .WebDisableDateRecognition = Not (is日付に変換する)
        
        .Refresh BackgroundQuery:=False
        .Delete
    End With

End Sub

' 自動更新の停止
Sub エクセルの自動更新を停止する(isブック計算をOFFに As Boolean _
    , Optional is画面更新をOFFに As Boolean = True _
    , Optional isイベントをOFFに As Boolean = True)
    
    If isブック計算をOFFに Then Application.Calculation = xlCalculationManual
    If is画面更新をOFFに Then Application.ScreenUpdating = False
    If isイベントをOFFに Then Application.EnableEvents = False
    
End Sub

' 自動更新の開始
Sub エクセルの自動更新を開始する()
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .StatusBar = False
        .DisplayAlerts = True
    End With
End Sub

解説

本問題はSQLを使ってAccessからデータをとってくる問題で、

  • SQLでマスタの結合や抽出まですべてやってしまう。
  • SQLでは全データをとってくるだけにして、後の処理はVBAと数式でやる。

この2通りのやり方が考えられますが、私の解答は後者を用いました。

特に「マスタの結合」に関してはV/XLOOKUPの十八番であるため、
Formulaで行う方がSQLより簡単かつ高速に実装できると思います。


また「Access指定テーブルをシートに書き出し」を汎用関数化しているので、
一度作れば中身を見なくてもよいという恩恵も得ることができます。

この関数さえ用意しておけばSQLのことは一旦忘れていいということですね。


残りの「データの抽出」部分ですが、ここは単純な転記処理ではなく、

  1. データ全行をループし、条件を満たす行か判定
  2. 条件を満たす行を一次元配列としてDictionaryに格納していく
  3. Itemが配列のDictionaryが出来上がるので、これを二次元配列にする
  4. 二次元配列をセルに出力する

という手順を踏みました。

これはひとえに高速化が目的で、通常のセル間転記の数千倍の速度が出るコードになっていると思います。


マクロの速度はRangeオブジェクトへのアクセス回数を減らすのが肝ですが、
このコードは最後の「二次元配列→セル」の1回だけのため高速ということですね。


なお、Itemが配列のDictionaryのItems(Itemの配列)を取得すると、
これは配列の配列、いわゆるジャグ配列になっています。

この時「ジャグ配列→二次元配列」の変換関数を用意しておくと、
セルへの出力コードをものすごく簡単に書けるようになります。


Dictionaryを使い倒したい方は必須と言ってよい関数ですので、
自作するなり本記事から持っていくなりして準備しておきましょう。



本解答は配列・Dictionary・Formulaというマクロ高速化トリオをすべて使った、
高速マクロの教科書コードになっています。

データ処理を高速化したい場合は本コードを参考にしてみてください。