VBAで簡単に集計

質問

よろしくお願いします。

12月1日りんご10個
　　　　　バナナ5個
　　　　　りんご4個
12月2日バナナ12個
　　　　　りんご6個
　　　　　りんご5個
　　　　　バナナ3個
といったエクセルのデータを

12月1日りんご14個
　　　　　バナナ5個
12月2日りんご11個
　　　　　バナナ15個

というふうに集計するにはどうしたらよいのでしょう。

回答No.2

KURUMITO

簡単に集計したいとのことですがマクロを使ったからといって必ずしも良い方法ではありません。マクロは作業列と関数を使った方法に比べてデータが多くなればはるかに計算速度が遅くなります。
作業列と配列数式などを使わない関数で処理できるのでしたらそのことを推奨します。お尋ねのようなケースはマクロでなくとも処理できるケースなのでその方法を次に示します。
元のデータがシート１に有って日付、品名、個数の項目名がA１セルからC１セルに、各データが下方に入力されているとします。
お求めの表では日付が自動的に表示され、品名が日付が変わっても同じ順序で表示させるようにするためには、しかもA列での日付は同じ日付の場合には空のセルにするなど結構面倒な作業になります。そのためシート１ではD列からF列までに作業列を作ることにします。
D２セルには次の式を入力して下方にドラッグコピーします。

=IF(B2="","",IF(A2<>"",ROUNDDOWN(MAX(D$1:D1),-2)+101,IF(COUNTIF(INDEX(B:B,MATCH(10^10,A$1:A2)):B2,B2)=1,D1+1,"")))

E２セルには次の式を入力して下方にドラッグコピーします。

=IF(B2="","",IF(COUNTIF(B$2:B2,B2)=1,MAX(E$1:E1)+1,INDEX(E$1:E1,MATCH(B2,B:B,0))))

F２セルには次の式を入力して下方にドラッグコピーします。

=IF(B2="","",IF(A2<>"",A2*1000+E2,ROUNDDOWN(F1,-3)+E2))

次にお求めの表をシート２に作成するとして
A１セルに日付、B１セルに品名、C１セルに個数と項目名を入力します。
A２セルには次の式を入力して下方にドラッグコピーします。

=IF(ROW(A1)>COUNT(Sheet1!D:D),"",IF(INDEX(Sheet1!A:A,MATCH(SMALL(Sheet1!D:D,ROW(A1)),Sheet1!D:D,0))=0,"",INDEX(Sheet1!A:A,MATCH(SMALL(Sheet1!D:D,ROW(A1)),Sheet1!D:D,0))))

B２セルには次の式を入力して下方にドラッグコピーします。

=IF(ROW(A1)>COUNT(Sheet1!D:D),"",INDEX(Sheet1!B:B,MATCH(LOOKUP(10^10,A$1:A2)*1000+ROW()-MATCH(10^10,A$1:A2)+1,Sheet1!F:F,0)))

C２セルには次の式を入力して下方にドラッグコピーします。

=IF(B2="","",SUMIF(Sheet1!F:F,LOOKUP(10^10,A$1:A2)*1000+ROW()-MATCH(10^10,A$1:A2)+1,Sheet1!C:C))

最後にA列を選択してセルの表示形式から日付にします。
なお、シート１での作業列が目障りでしたらはそれらの列を選択して右クリックし「非表示」を選択すればよいでしょう。

回答No.1

tom04

こんばんは！
作業用の列を使えば関数でも対処できそうな感じですが、
VBAでの方法をご希望だというコトなので・・・
一例です。

Sheet1のデータをSheet2にまとめるようにしてみました。
表のレイアウトは↓の画像のようになっているとします。
標準モジュールにコピー＆ペーストしてマクロを実行してみてください。

Sub 集計()
Dim i As Long, n As Long
Dim wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")

Application.ScreenUpdating = False
wS2.Cells.ClearContents
wS1.Cells(1, 1).CurrentRegion.Copy wS2.Cells(1, 2)
i = wS2.Cells(Rows.Count, 3).End(xlUp).Row
Range(Cells(2, 1), Cells(i, 1)).Formula = "=IF(B2="""",MAX(B$2:B2),B2)&""_""&C2"
For i = wS2.Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
If WorksheetFunction.CountIf(wS2.Columns(1), wS2.Cells(i, 1)) > 1 Then
If wS2.Cells(i, 1) <> "" Then
n = WorksheetFunction.Match(wS2.Cells(i, 1), wS2.Columns(1), False)
wS2.Cells(n, 4) = wS2.Cells(n, 4) + wS2.Cells(i, 4)
wS2.Rows(i).Delete
End If
End If
Next i
wS2.Columns(1).Delete
Application.ScreenUpdating = True
End Sub

こんな感じではどうでしょうか？m(_ _)m