VBA100本ノック 97本目:Accessデータを取得(グループ集計)
Accessからデータを取得(グループ集計)する問題です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。
出題
DB1.accdbから取引先&商品で集計出力する。
■出力項目
取引先CD,取引先名,商品CD,商品名,数量合計,金額合計,平均単価,標準単価,最低単価
平均単価は金額/数量(整数に丸め)
最低単価は全取引先での商品の最低単価
■抽出条件
平均単価 > 標準単価
※シートは任意


サンプルファイルです。
https://excel-ubara.com/vba100sample/DB1.accdb
https://excel-ubara.com/vba100sample/DB1.xlsx
https://excel-ubara.com/vba100sample/VBA100_96.zip
xlsxはaccdbをExcelにしたものです。
zipには両方入っています。
時にはそういう工夫をすることも大切です。
もちろん1発で済めばそれに越したことはありませんが。
VBA作成タイム
この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。
他の人の回答および解説を見て、書いたVBAを見直してみましょう。
頂いた回答
解説
悩ましい部分は「最低単価」でしょうか。
これには最低単価だけを求めるサブクエリを作成して対応します。
そのサブクエリを他のマスタ同様にJOINすれば完成します。
また、GROUPの結果に対して絞り込む場合はHAVINGを使います。
Function createSql(Optional ByVal isExcel As Boolean = False) As String
Dim sql() As String: ReDim sql(0)
sqlAppend sql, " SELECT"
sqlAppend sql, " T1.取引先CD"
sqlAppend sql, ",M1.取引先名"
sqlAppend sql, ",T1.商品CD"
sqlAppend sql, ",M2.商品名"
sqlAppend sql, ",SUM(T1.数量) AS 数量合計"
sqlAppend sql, ",SUM(T1.数量 * T1.単価) AS 金額合計"
sqlAppend sql, ",ROUND(SUM(T1.数量 * T1.単価) / SUM(T1.数量),0) AS 平均単価"
sqlAppend sql, ",M2.標準単価"
sqlAppend sql, ",S1.最低単価"
sqlAppend sql, " FROM ((([T売上] T1"
sqlAppend sql, " LEFT JOIN [M取引先] AS M1 ON T1.取引先CD = M1.取引先CD)"
sqlAppend sql, " LEFT JOIN [M商品] AS M2 ON T1.商品CD = M2.商品CD)"
sqlAppend sql, " LEFT JOIN (SELECT 商品CD,MIN(単価) AS 最低単価"
sqlAppend sql, " FROM [T売上]"
sqlAppend sql, " GROUP BY 商品CD) AS S1"
sqlAppend sql, " ON T1.商品CD = S1.商品CD)"
sqlAppend sql, " GROUP BY T1.取引先CD,M1.取引先名,T1.商品CD,M2.商品名,M2.標準単価,S1.最低単価"
sqlAppend sql, " HAVING ROUND(SUM(T1.数量 * T1.単価) / SUM(T1.数量),0) > M2.標準単価"
createSql = Join(sql)
If isExcel Then
createSql = Replace(createSql, "[T売上]", "[T売上$] ")
createSql = Replace(createSql, "[M取引先]", "[M取引先$] ")
createSql = Replace(createSql, "[M商品]", "[M商品$] ")
End If
End Function
HAVINGを使わずにWHEREで絞り込めます。
さらに「最低単価」も一段上のクエリでJOINすることもできます。
このSQLと全VBAおよび若干の追加説明を記事補足に記載しました。
補足
Option Explicit
Sub VBA100_97_01()
Dim ws As Worksheet: Set ws = Worksheets("売上")
Dim sDb As String
sDb = ThisWorkbook.Path & "\DB1.accdb" '"\DB1.xlsx"
Call VBA100_97_ADO(sDb, ws)
End Sub
Sub VBA100_97_ADO(ByVal aDb As String, ws As Worksheet)
Dim adoCn As New ADODB.Connection
Dim adoRs As ADODB.Recordset
Dim sSql As String, isExcel As Boolean
Set adoCn = getConnection(aDb, isExcel)
adoCn.Open aDb
Set adoRs = adoCn.Execute(createSql(isExcel))
Call outputSheet(ws, adoRs)
adoRs.Close: Set adoRs = Nothing
adoCn.Close: Set adoCn = Nothing
End Sub
Function getConnection(ByVal aDb As String, ByRef isExcel As Boolean) As ADODB.Connection
Dim adoCn As New ADODB.Connection
Select Case Mid(aDb, InStrRev(aDb, ".") + 1)
Case "accdb"
With adoCn
.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
End With
isExcel = False
Case "xlsx", "xlsm"
With adoCn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Extended Properties") = "Excel 12.0"
End With
isExcel = True
End Select
Set getConnection = adoCn
End Function
Sub outputSheet(ByVal ws As Worksheet, adoRs As ADODB.Recordset)
Dim i As Long
With ws
.Cells.Clear
For i = 0 To adoRs.Fields.Count - 1
.Cells(1, i + 1) = adoRs.Fields(i).Name
Next
.Range("A2").CopyFromRecordset adoRs
.Columns("E:I").NumberFormatLocal = "#,##0"
.Range("A1").CurrentRegion.EntireColumn.AutoFit
End With
End Sub
Function createSql(Optional ByVal isExcel As Boolean = False) As String
Dim sql() As String: ReDim sql(0)
sqlAppend sql, " SELECT"
sqlAppend sql, " T1.取引先CD"
sqlAppend sql, ",M1.取引先名"
sqlAppend sql, ",T1.商品CD"
sqlAppend sql, ",M2.商品名"
sqlAppend sql, ",SUM(T1.数量) AS 数量合計"
sqlAppend sql, ",SUM(T1.数量 * T1.単価) AS 金額合計"
sqlAppend sql, ",ROUND(SUM(T1.数量 * T1.単価) / SUM(T1.数量),0) AS 平均単価"
sqlAppend sql, ",M2.標準単価"
sqlAppend sql, ",S1.最低単価"
sqlAppend sql, " FROM ((([T売上] T1"
sqlAppend sql, " LEFT JOIN [M取引先] AS M1 ON T1.取引先CD = M1.取引先CD)"
sqlAppend sql, " LEFT JOIN [M商品] AS M2 ON T1.商品CD = M2.商品CD)"
sqlAppend sql, " LEFT JOIN (SELECT 商品CD,MIN(単価) AS 最低単価"
sqlAppend sql, " FROM [T売上]"
sqlAppend sql, " GROUP BY 商品CD) AS S1"
sqlAppend sql, " ON T1.商品CD = S1.商品CD)"
sqlAppend sql, " GROUP BY T1.取引先CD,M1.取引先名,T1.商品CD,M2.商品名,M2.標準単価,S1.最低単価"
sqlAppend sql, " HAVING ROUND(SUM(T1.数量 * T1.単価) / SUM(T1.数量),0) > M2.標準単価"
createSql = Join(sql)
If isExcel Then
createSql = Replace(createSql, "[T売上]", "[T売上$] ")
createSql = Replace(createSql, "[M取引先]", "[M取引先$] ")
createSql = Replace(createSql, "[M商品]", "[M商品$] ")
End If
End Function
Sub sqlAppend(ByRef sql, ByVal aString As String)
ReDim Preserve sql(1 To UBound(sql) + 1)
sql(UBound(sql)) = aString & vbCrLf
End Sub
つまり、集計関数を使わないカラムをSELECTに指定する場合は、GROUP BYにも必ず指定することになります。
※ただし一部のデータベースでは、この制約がない場合もあります。
最低単価を求めるクエリだけを作るのは比較的簡単です。
HAVINGはGROUP BYより後ろに記述してください。
各区の順番は以下のようになります。
FROM
WHERE
GROUP
HAVING
ORDER
一段上のクエリを作成して、そこで、
・最低単価
・平均単価 > 標準単価
この2点を処理するようにしたものが以下のSQLになります。
ぜひ見比べて、処理の違いを確認してみてください。
Function createSql(Optional ByVal isExcel As Boolean = False) As String
Dim sql() As String: ReDim sql(0)
sqlAppend sql, "SELECT G1.*,S1.最低単価 FROM"
sqlAppend sql, "(SELECT"
sqlAppend sql, " T1.取引先CD"
sqlAppend sql, ",M1.取引先名"
sqlAppend sql, ",T1.商品CD"
sqlAppend sql, ",M2.商品名"
sqlAppend sql, ",SUM(T1.数量) AS 数量合計"
sqlAppend sql, ",SUM(T1.数量 * T1.単価) AS 金額合計"
sqlAppend sql, ",ROUND(SUM(T1.数量 * T1.単価) / SUM(T1.数量),0) AS 平均単価"
sqlAppend sql, ",M2.標準単価"
sqlAppend sql, " FROM (([T売上] T1"
sqlAppend sql, " LEFT JOIN [M取引先] AS M1 ON T1.取引先CD = M1.取引先CD)"
sqlAppend sql, " LEFT JOIN [M商品] AS M2 ON T1.商品CD = M2.商品CD)"
sqlAppend sql, " GROUP BY T1.取引先CD,M1.取引先名,T1.商品CD,M2.商品名,M2.標準単価"
sqlAppend sql, ") AS G1"
sqlAppend sql, " LEFT JOIN (SELECT 商品CD,MIN(単価) AS 最低単価"
sqlAppend sql, " FROM [T売上]"
sqlAppend sql, " GROUP BY 商品CD) AS S1"
sqlAppend sql, " ON G1.商品CD = S1.商品CD"
sqlAppend sql, " WHERE G1.平均単価 > G1.標準単価"
createSql = Join(sql)
If isExcel Then
createSql = Replace(createSql, "[T売上]", "[T売上$] ")
createSql = Replace(createSql, "[M取引先]", "[M取引先$] ")
createSql = Replace(createSql, "[M商品]", "[M商品$] ")
End If
End Function
96本目:Accessからデータを取得1
サイト内関連ページ
同じテーマ「VBA100本ノック」の記事
94本目:表範囲からHTMLのtableタグを作成
95本目:図形のテキストを検索するフォーム作成
96本目:Accessデータを取得(マスタ結合&抽出)
97本目:Accessデータを取得(グループ集計)
98本目:席替えルールが守られているか確認
99本目:自動席替え(行列と前後左右が全て違うように)
100本目:WEBから100本ノックのリストを取得
魔球編:組み合わせ問題
魔球編:閉領域の塗り潰し
迷宮編:巡回セル問題
魔球編:2桁の最小公倍数
新着記事NEW ・・・新着記事一覧を見る
WshNetwork(ネットワークドライブの割り当て等)|VBA技術解説(2025-04-09)
TRANSLATE関数(翻訳) DETECTLANGUAGE関数(言語識別)|エクセル入門(2025-04-08)
QRコード、バーコード作成の覚え書き|エクセル関数応用(2025-04-05)
TRIMRANGE関数(セル範囲をトリム:端の空白セルを除外)|エクセル入門(2024-08-30)
正規表現関数(REGEXTEST,REGEXREPLACE,REGEXEXTRACT)|エクセル入門(2024-07-02)
エクセルが起動しない、Excelが立ち上がらない|エクセル雑感(2024-04-11)
ブール型(Boolean)のis変数・フラグについて|VBA技術解説(2024-04-05)
テキストの内容によって図形を削除する|VBA技術解説(2024-04-02)
ExcelマクロVBA入門目次|エクセルの神髄(2024-03-20)
VBA10大躓きポイント(初心者が躓きやすいポイント)|VBA技術解説(2024-03-05)
アクセスランキング ・・・ ランキング一覧を見る
1.最終行の取得(End,Rows.Count)|VBA入門
2.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
3.繰り返し処理(For Next)|VBA入門
4.変数宣言のDimとデータ型|VBA入門
5.RangeとCellsの使い方|VBA入門
6.ひらがな⇔カタカナの変換|エクセル基本操作
7.セルのクリア(Clear,ClearContents)|VBA入門
8.メッセージボックス(MsgBox関数)|VBA入門
9.ブックを閉じる・保存(Close,Save,SaveAs)|VBA入門
10.条件分岐(Select Case)|VBA入門
- ホーム
- マクロVBA入門編
- VBA100本ノック
- 97本目:Accessデータを取得(グループ集計)
このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。
記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。