【excelマクロVBA】表の集計・転記マクロの改造点について

質問

以前、こちらのカテゴリーで重複をチェックしてその行を削除し表を整頓するマクロとしてプログラムを教えて頂きました。
　　　（資材受け入れシート）　　→　　　（Sheet2）
受入日　品名　 Lot　 数量　 　受入日　品名　 Lot　 数量
　　7/7 　　A　 BNR32　 10　　 　7/8 　　A　 BNR32　 15
　　7/8 　　A　 BNR32　 5　　　　7/10 　 B　 SW200　 14
　　7/10 　 B　 SW200　 2　→　　7/7 　　B　 AE860　 4
　　7/7 　　B　 AE860　 4　　　　7/9 　　C　 GD300　 11
　　7/8 　　B　 SW200　 12　　 　7/7 　　C　 DC200　 7
　　7/9 　　C　 GD300　 10
　　7/7 　　C　 GD300　 1
　　7/7 　　C　 DC200　 7
プログラムの内容は、
Sub test()
　　Dim strSql As String
　　Dim cnXL As Object
　　Dim rsXL As Object
　　Const adOpenForwardOnly = 0

　　Sheets("資材受け入れシート").Range("A1:D1").Copy
　　Sheets("資材受け入れシート").Paste Destination:=Worksheets("Sheet2").Range("A1:D1")
　　Application.CutCopyMode = False

　　Set cnXL = CreateObject("ADODB.Connection")
　　Set rsXL = CreateObject("ADODB.Recordset")

　　With cnXL
　　　　.Provider = "MSDASQL"
　　　　.ConnectionString = "Driver={Microsoft Excel Driver (*.xls)};" & _
　　　　"DBQ=" & ThisWorkbook.FullName & "; ReadOnly=True;"
　　　　.Open
　　End With

　　strSql = "select max(受入日) as 日付,品名,Lot,sum(数量) as 合計" _
　　　　　　　　& " from [資材受け入れシート$]" _
　　　　　　　　& " group by 品名,Lot order by max(受入日),品名,Lot"

　　Debug.Print strSql
　　rsXL.Open strSql, cnXL, adOpenForwardOnly

　　Worksheets("sheet2").Cells(2, 1).CopyFromRecordset rsXL
　　Worksheets("sheet2").Columns("A:A").NumberFormatLocal = "m/d"

　　rsXL.Close: Set rsXL = Nothing
　　cnXL.Close: Set cnXL = Nothing
　　MsgBox "Sheet2に出力しました"
End Sub
と記述されており、正常に動作いたしました。
ところが、会社から受入日，品名，Lot，数量だけでなく、納入業者，賞味期限，担当者の項目（列）を追加し転記できるように欲しいと命じられました。業務の都合上、列の順番は受入日，＜納入業者＞，品名，Lot，＜賞味期限＞，数量，＜担当者＞の順番で挿入し、追加した3項目については計算させる必要は無く、転記だけさせたいと考えています。上のプログラムを元に改造を試みたのですが、転記が上手くできません。どこの部分にどのように記述・変更したら良いのかが分りません。どなたかご存知の方、お教え願えませんでしょうか？表の作成までにもう少しというところで躓いてしまい頭を悩ませております。初歩的な質問かもしれませんが、宜しくお願い致します。

回答No.4

pauNed

（#2補足へのレスです）
>ピボットテーブルも試させていただきましたが、無事動きました。
あら♪良かったです。結構便利ですよ^ ^
データ量が増えても、ピボット右クリック[データの更新]で対応できますし。

>しかし、ピボットテーブル上では行削除できないのと...
おっしゃるとおりです。
ですので
『そこから別シートにでもコピーして体裁を整えれば良いかと。』と書いたわけです。
以下コードは、できたピボットテーブルがあるシートをアクティブにして実行してください。

Sub sample2()
　　'例のピボットがあるシートを選択して実行
　　If ActiveSheet.PivotTables.Count > 0 Then
　　　　With ActiveSheet.PivotTables(1).TableRange1
　　　　　　Intersect(.Cells, .Offset(1)).Copy
　　　　End With
　　　　Sheets.Add
　　　　Range("A1").PasteSpecial xlPasteValues
　　　　Application.CutCopyMode = False
　　　　With Selection.Columns("A:B").Resize(Selection.Rows.Count - 1)
　　　　　　.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
　　　　　　.Value = .Value
　　　　End With
　　　　Selection.Columns("E:F").NumberFormat = "yy/mm/dd"
　　Else
　　　　MsgBox "no table"
　　End If
End Sub

新規シートにピボットデータを値で貼り付けて、項目の空白を埋めます。
これでできたデータは自由に加工できます。

もうひとつ。
>表の1行と3行の間の空白行は削除すること（項目とデータを詰める）はできないのでしょうか？
推測ですが、"資材受け入れシート"のデータがない範囲にゴミがあるのかも。
[Ctrl]キー＋[End]キー同時押しでどこが選択されますか？
データ最終行の次から、その行選択して、行削除してみてください。

回答No.3

imogasi

SQLのことが勉強できて無い方に、SQL回答がでて、質問者が採用したのも問題があると思うが、いまさら頭を混乱させてもすまない、と思うが、参考までにエクセルのシートだけで処理するVBAを載せます。私の好きなソート法です。
コメントを詳しく入れたので、どういう理屈になっているか、分かれば、判りやすい方法と、手前味噌をつけておきます。
Sheet1が原データシート名、結果はSheet2に出ます。第１行目の
見出しは貼り付けてください（手抜き）。A列は日付書式に設定してください（手抜き）。
項目が増えたら、j=1 to 5の5を（２箇所）とソートの範囲を増やしてください。E列は連番を手作業で振りました。元の順に戻すためです。
ーー
VBEの標準モジュールに
Sub test01()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
'--
d = sh1.Range("A65536").End(xlUp).Row
sh1.Range("A2", sh1.Cells(d, "E")).Sort key1:=sh1.Range("C2"), order1:=xlAscending
'--開始前処理
m = sh1.Cells(2, "C")
t = sh1.Cells(2, "D")
k = 2 '第2行から書き出し
'--最初行書き出し
For j = 1 To 5 'A-E行について
sh2.Cells(k, j) = sh1.Cells(2, j) '各列書き出し
Next j
'--
For i = 3 To d
If sh1.Cells(i, "C") = m Then
'合計に加算だけ
t = t + sh1.Cells(i, "D") 'D列を足しこみ
Else
'--書き出し
sh2.Cells(k, "D") = t '合計を書き出し
'--行を進めて、本件を書き出し（D列は取り合えず仮に）
k = k + 1 '書き出し次行をポイント
For j = 1 To 5 'A-E行について
sh2.Cells(k, j) = sh1.Cells(i, j) '本件各列書き出し
Next j
t = 0 '小計ご破算
t = t + sh1.Cells(i, "D") '本件足しこみ
m = sh1.Cells(i, "C") '本件をキーに設定
End If
Next i
'--終了
sh2.Cells(k, "D") = t '合計を書き出し
'--元の順に並べ替え
sh1.Range("A2", sh1.Cells(d, "E")).Sort key1:=sh1.Range("E1")
sh2.Range("A2", sh2.Cells(k - 1, "E")).Sort key1:=sh2.Range("E1")
End Sub

回答No.2

pauNed

あら？^ ^;
順番間違ってましたね。失礼orz

strSql = "select max(受入日) as 日付,納入業者,品名,Lot," _
　　　 & "max(賞味期限) as 日付2,sum(数量) as 合計,担当者" _
　　　 & " from [資材受け入れシート$]" _
　　　 & " group by 納入業者,品名,Lot,担当者 order by max(受入日),品名,Lot"

もし現状のコードをお使いになられるなら、データ量にもよりますが、
繰り返し処理する場合のメモリエラーに気をつけるようにしてください。
BUG: Memory leak occurs when you query an open Excel worksheet by using ActiveX Data Objects (ADO)
http://support.microsoft.com/kb/319998/ja
開いているxlsBookに対して処理する時の現象なので、
元データは別Bookにして閉じておいたほうが良いかもしれません。

また、今後の理解のためには、ADO や SQL をキーワードに検索して調べられると良いと思います。
VBAからの扱いは、下記が参考になると思います。
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_130.html

補足

お忙しいところ、ご回答ありがとうございました。
pauNed様のANo.1を元に無い頭を使っていろいろ試したのですが、結局できませんでした。ピボットテーブルも試させていただきましたが、無事動きました。しかし、ピボットテーブル上では行削除できないのと、ピボットテーブルのコピペ（値）をした時に空白セル（項目が集約された部分）ができてしまうのでこれでは・・・と悩んでいたところでした。在庫表を作成する上で「数量」項目部分で0（その品名がもう存在しない場合）が転記された場合、その行を削除しようと考えています。ANo.2でお答え頂いたコードで無事転記できました。ありがとうございます。質問とは関係無いのですがこのプログラムで転記された表の1行と3行の間の空白行は削除すること（項目とデータを詰める）はできないのでしょうか？もしご存知でしたらお教え願います。

回答No.1

pauNed

こんにちは。

>strSql = "select max(受入日) as 日付,品名,Lot,sum(数量) as 合計" _
>　　　 & " from [資材受け入れシート$]" _
>　　　 & " group by 品名,Lot order by max(受入日),品名,Lot"
ここを
strSql = "select max(受入日) as 日付,品名,納入業者,Lot," _
　　　 & "max(賞味期限) as 日付2,sum(数量) as 合計,担当者" _
　　　 & " from [資材受け入れシート$]" _
　　　 & " group by 品名,納入業者,Lot,担当者 order by max(受入日),品名,Lot"

>Worksheets("sheet2").Columns("A:A").NumberFormatLocal = "m/d"
ここを
Worksheets("sheet2").Range("A:A,E:E").NumberFormatLocal = "m/d"

...などと変えたらできるかもしれません。
ただ、現状のシート状態と集計条件が今ひとつ不明確なためよくわかりません。

それにしても、メンテナンスできないと意味がないのではないでしょうか？
業務に使うのであれば、集計結果には自信を持って提出しないと？
自分で理解しておかないと不安じゃないですか？

データの集計条件によっては、今できている集計結果に、
作業列を使ってでも、VLOOKUP関数で追加項目をひっぱってきて、
列並び替えで対応できそうですけど。
そこぐらいは手作業でもできませんか？

あと、一般機能の[名前定義]と[ピボットテーブル]をうまく使って
集計できそうな気もします。

以下『一例』（項目名称によってはうまくいかない場合もあります）
Sub sample1()
　　Dim v, vi

　　v = Array("納入業者", "品名", "Lot", "担当者")
　　With ActiveWorkbook
　　　　.Names.Add Name:="database", _
　　　　　　　　　 RefersTo:="=offset(資材受け入れシート!$A$1,0,0,counta(資材受け入れシート!$A:$A),7)"
　　　　With .PivotCaches.Add(SourceType:=xlDatabase, _
　　　　　　　　　　　　　　　SourceData:="database") _
　　　　　　　　　　　　　　　.CreatePivotTable(TableDestination:="")
　　　　　　.AddFields RowFields:=v, ColumnFields:="データ"
　　　　　　For Each vi In v
　　　　　　　　.PivotFields(vi).Subtotals(1) = False
　　　　　　Next vi
　　　　　　For Each vi In Array("受入日", "賞味期限")
　　　　　　　　With .PivotFields(vi)
　　　　　　　　　　.Orientation = xlDataField
　　　　　　　　　　.Caption = vi & "_"
　　　　　　　　　　.Function = xlMax
　　　　　　　　　　.NumberFormat = "yy/mm/dd"
　　　　　　　　End With
　　　　　　Next vi
　　　　　　With .PivotFields("数量")
　　　　　　　　.Orientation = xlDataField
　　　　　　　　.Caption = "数量_"
　　　　　　　　.NumberFormat = "#,##0"
　　　　　　End With
　　　　End With
　　End With
End Sub
手作業でできる事をコード化したものです。
これでうまくいくようなら、ピボットテーブルができますから、
そこから別シートにでもコピーして体裁を整えれば良いかと。
（データが増えても[更新]だけで集計し直せるテーブルです）