エクセル 表の集計

質問

エクセルは2017です。
〇いままでのやりかた(添付写真をみてください)
1．会社の基幹システムから製番と回答納期、発注数（オーダー数）、個数をダウンロードします。（実際のリストはもっと項目があり、オーダー数は30,000件になります。）なので必要なのを抜粋しています。
2．ピボットで表を集計します。（添付写真右側）
3．自分で作成した必要な製番だけのリスト（添付写真中央）を作成し、関数を使って日ごとのオーダー数を表示させてます。
〇やりたいこと
・マクロを使って1ボタンで自分の作成したリストにオーダー数をいれたい。
1→基幹システムから任意のホルダーにリストを保存
2→自分で作成したリストに「集計」ボタンがありそれをクリック
3→保存先を聞いてきてリストが保存してあるフォルダーを選択
4→フォルダー内にあるリストを選択すると自動的に自分で作成したリストに数字がはいる。

よろしくお願いします。

回答No.2

HohoPapa · ベストアンサー

時間ができたので書いてみました。
よかったら試してみてください。

なお、以下が制限事項です。
・基幹システムから切り出したデータのレコード群は最大、50000レコード（1行目ヘッダー行を含む）まで
・列数は最大２６列
・データはエクセルファイルのシートに格納され、
　そのシート名は"Sheet1"
・「2→自分で作成したリスト」には、A6セルから製番が始まっている
・エラー処理は全く考慮していません。

Option Explicit

Sub Sample()

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Dim InList As String
　Dim r As Long
　Dim c As Long
　Dim strFilePath As String

　strFilePath = _
　　　Application.GetOpenFilename(Filefilter:="Excelブック,*.xlsx")

　'型番リスト組立
　With ThisWorkbook.Sheets(1)
　　InList = ""
　　r = 6　 'リストの開始行
　　InList = InList & "'" & .Cells(r, 1).Value & "'" & vbCrLf
　　Do
　　　r = r + 1
　　　If .Cells(r, 1).Value = "" Then Exit Do
　　　InList = InList & ",'" & .Cells(r, 1).Value & "'" & vbCrLf
　　Loop
　End With

　'SQL全文を組み立て
　SQL = "SELECT [回答納期]" & vbCrLf
　SQL = SQL & "FROM [" & "Sheet1" & "$A1:Z50000]" & vbCrLf
　SQL = SQL & "Where [型番] in(" & InList & ")" & vbCrLf
　SQL = SQL & "GROUP BY [回答納期]" & vbCrLf
　SQL = SQL & "ORDER BY [回答納期]" & vbCrLf

　'SQLを実行
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open strFilePath
　rs.Open SQL, cn

　'結果セットを順番に読み、集計先、横方向に日付を羅列
　If Not rs.EOF Or Not rs.Bof Then
　　rs.MoveFirst
　　c = 1
　　Do
　　　If rs.EOF = True Then Exit Do
　　　With ThisWorkbook.Sheets(1)
　　　　c = c + 1
　　　　.Cells(5, c).Value = rs("回答納期")
　　　　.Cells(5, c).NumberFormatLocal = "yyyy/m/d"
　　　End With
　　　rs.MoveNext
　　Loop
　End If

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

　With ThisWorkbook.Sheets(1)
　　c = 2　'編集先テーブルの開始列
　　Do
　　　If .Cells(5, c).Value = "" Then Exit Do
　　　r = 6　'編集先テーブルの開始行
　　　Do
　　　　If .Cells(r, 1).Value = "" Then Exit Do
　　　　.Cells(r, c).Value = _
　　　　　　sfCount(strFilePath, .Cells(r, 1).Value, .Cells(5, c).Value)
　　　　r = r + 1
　　　Loop
　　　'日ごとの合計算出
　　　.Cells(4, c).Value = _
　　　　　Application.WorksheetFunction. _
　　　　　Sum(Range(.Cells(6, c), .Cells(50000, c)))
　　　c = c + 1
　　Loop
　End With

End Sub

Function sfCount(Path As String, Kataban As String, Nouki As Date) As Long

　Dim SQL As String
　Dim cn As Object
　Dim rs As Object
　Dim InList As String
　Dim r As Long
　Dim c As Long

　'SQL全文を組み立て
　SQL = "SELECT Count([回答納期]) as HitCount" & vbCrLf
　SQL = SQL & "FROM [" & "Sheet1" & "$A1:Z50000]" & vbCrLf
　SQL = SQL & "Where (([型番] =　'" & Kataban & "') and " & vbCrLf
　SQL = SQL & "( [回答納期] =　#" & Format(Nouki, "yyyy/mm/dd") & "#))" & vbCrLf

　'SQLを実行
　Set cn = CreateObject("ADODB.Connection")
　Set rs = CreateObject("ADODB.Recordset")
　cn.Provider = "Microsoft.ACE.OLEDB.12.0"
　cn.Properties("Extended Properties") = "Excel 12.0;HDR=Yes;IMEX=1"
　cn.Open Path
　rs.Open SQL, cn

　'結果セットを取得
　sfCount = rs("HitCount")

　'後処理
　rs.Close
　Set rs = Nothing
　cn.Close
　Set cn = Nothing

End Function

回答No.1

imogasi

ーー
（1)この質問には、自社の自分の仕事のことだろう。
貴社は、システム部や提携ソフト業者が居るようだ。そちらに依頼して
最終目標に近いデータを吐き出してもらうように、
SAMUFS関数を使うぐらいで、残りは済むようにしてもらったらどうか。
ーーー
仮にVBAコードがわかったとして、会社は、それを加工するVBAを、
使うことを許すのか。
質問の表現ぶりから、許さない方がよいようにおもう。
ーーー
やりたい内容は、ダウンロードしたデータで
（１）ピボットで集計する、らしい。条件や項目（フィ-ルド名）は具体的にはなに？
（２）>必要な製番リスト＋データ？を作るらしいが、具体的には、方法はなに？
関数は抜出しは不得手と思うが、フィルタかその他なら何？
ーー
（１）ダウンロードデータ（シート）
（２）中間データ(シート）
（３）最終目的データ
と（２）を中間にかました方がよいように思う。
（３）はクロスならピボットを使うとか、場合によってはエクセル関数で処理するほうが
良いのではないか
＝＝＝
小生などは
（１）ーー＞（２）のフィルタ的な庶路（セータ変形的なものはないのだろう）を文章で
（２）ーー＞（３）の処理をフィールド名と、文章で
説明してくれた方が、理解しやすい。
＝＝
本日、日曜であり、オリパラテレビ観戦でいそがしいかもしれないが、２－３日経って回答が
出ないようなら小生の言うことも影響していると思って質問の仕方を工夫しては．
参考にピボットテーブルのＶＢＡでの課題例を見つけたので
https://www.relief.jp/docs/excel-vba-filter-pivot-table.html
VBAでピボットテーブルのフィルターを設定する
を上げてみる。