EXCEL 複数列にまたがる複数表の集約・並び変え

質問

教えてくださいm(__)m

上司が旧前から使用している仕入表の集約に悪戦苦闘。
同一シートで複数列（行）にまたがる同じ形式の仕入表をさらに集約したいと思ったんですが、
うまくいきません。ご教示願います。
　　A　　　B　　　C　　　D　　　　E　　　　F　　　G　　　H　　　I　　　J　　　　・・・・・・・・・　
1日付　品目　数量　金額　ブランク　日付　品目　数量　金額　ブランク
2　○　　○　　　○　　　○　　　　　　　　●　　●　　　●　　●　　
3　・
4　・
5　・
6日付　品目　数量　金額　ブランク　日付　品目　数量　金額　ブランク
7　△　　△　　　△　　　△　　　　　　　　▲　　▲　　　▲　　▲
8　・
9　・
10 ・

これを日付毎に・・・
　　A　　　B　　　C　　　D　　
1日付　品目　数量　金額
2　○　　○　　　○　　○
3　△　　△　　　△　　△
4　▲　　▲　　　▲　　▲
5　●　　●　　　●　　●
6 ▲　　▲　　　▲　　▲
7 △　　△　　　△　　△
8 ▲　　▲　　　▲　　▲
9　 ・
10 ・

というように集約、日付毎に並べ変えしたく。

分かりづらい説明で申し訳ありません。

回答No.1

keithin · ベストアンサー

言わずもがなですが、日付にはダブりがあり得るものとします。また順不同とします。

シート１に２列の表があるとして
Ｅ２セルに
=IF(A2="","",COUNTIF($A:$A,"<"&A2)+COUNTIF($F:$F,"<"&A2)+1+ROW()/1000+COLUMN()/100000)
と記入、以下コピー

Ｅ列をコピー、Ｊ列に貼り付け

シート２に日付順を並べるとして
Ａ２に
=IF(ROW(A1)>COUNT(Sheet1!E:E,Sheet1!J:J),"",SMALL((Sheet1!E:E,Sheet1!J:J),ROW(A1)))
と記入、以下コピー

Ｂ２に
=IF($A2="","",INDIRECT("Sheet1!"&TEXT(MOD($A2,1)*100000-5+COLUMN(A2),"!R000!C00"),FALSE))
と記入、右にＥ列までコピー、下にコピーして完成。

お礼

ご丁寧にありがとうございました。
表が多数あり、集計表自体も量が多かったため数式の変更に少々手間取りましたが、
無事終了いたしました。有難うございます。

早々のご教示にてベストアンサーとさせていただきますm(__)m

回答No.2

K Kazz（@JazzCorp）

’5列セットで縦、横（横方向の繰り返しは2つだけ）にレイアウトされている、テーブルを1つにマージする
'同じ日付＆同じ品目のレコードは圧縮する
’結果は、ブックの最後に追加した別シートに出る
'ネタシートをアクティブにして実行
Option Explicit
Sub MergeTablewithSort()
Const xUnit = 5
Const xRept = 2
Const xHeads = 1
Dim xLast As Long
Dim xRow As Long
Dim xColumn As Long
Dim kk As Long
Dim mm As Long
Dim nn As Long
Debug.Print vbNewLine & Now & " ：Now！"
Application.ScreenUpdating = False
xRow = ActiveSheet.UsedRange.Rows.Count
xColumn = ActiveSheet.UsedRange.Columns.Count
ActiveSheet.Copy After:=Worksheets(Worksheets.Count)
Application.CutCopyMode = False
Range(Cells(xHeads + 1, "F"), Cells(xRow, "J")).Copy
' Cells(xRow + 1, "A").PasteSpecial xlPasteValuesAndNumberFormats
'Excel2000はコォ～なっちゃう、、、
With Cells(xRow + 1, "A")
.PasteSpecial xlPasteFormats
.PasteSpecial xlPasteValues
End With
Columns("F:J").Delete
xLast = Cells(Rows.Count, "A").End(xlUp).Row
For nn = xLast To (xHeads + 1) Step -1
'見出しは１つあれば十分！
If (Cells(nn, "A").Value = Cells(1, "A").Value) Then
Rows(nn).Delete
End If
Next
xLast = Cells(Rows.Count, "A").End(xlUp).Row
If (xLast > (xHeads + 1)) Then
Application.Calculation = xlCalculationManual
'Sortもオールドファッション！
Range(Rows(1), Rows(xLast)).Sort _
Key1:=Range("A1").Value, Order1:=xlAscending, _
Key2:=Range("B1").Value, Order2:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlPinYin
xLast = Cells(Rows.Count, "A").End(xlUp).Row
mm = xLast
For nn = (xLast - 1) To xHeads Step -1
'同じ日付＆同じ品目のレコードを圧縮
If (Cells(nn, "A").Value <> Cells(mm, "A").Value) Or (Cells(nn, "B").Value <> Cells(mm, "B").Value) Then
If (mm > nn + 1) Then
Rows((nn + 1) & ":" & (mm - 1)).Delete
End If
mm = nn
Else
Cells(mm, "C").Value = Cells(mm, "C").Value + Cells(nn, "C").Value
Cells(mm, "D").Value = Cells(mm, "D").Value + Cells(nn, "D").Value
End If
Next
Application.Calculation = xlCalculationAutomatic
Else
MsgBox ("ActiveSheet：" & ActiveSheet.Name & "：No Data Found !!")
End If
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

お礼

ご丁寧にありがとうございました。
先にご回答いただいた方の方法で実施（成功）し、貴殿の教示でも実施してみました（成功）。

勉強不足でした。本当にありがとうございました。