エクセルで学年会計簿を作りたい。

質問

学校で使う会計簿を作りたいと思っています。
シートが全部で４枚あり、シート１は「１学期」、シート２は「２学期」、シート３は「３学期」、
シート４は「会計報告書」というのをイメージしています。

シート１～３に関しては何とか作れているのですが、
最後にシート１～３のデータを抽出して、シート４に自動で移す所で戸惑っております。

例えばシート１の１学期の支出は以下のようになっていたとします。

　　　　項目　　　　 　　　金額
国語テスト(1学期)　　　　\280
算数テスト(1学期) 　　　　\280
計算ドリル(上) 　　　　　　\450
理科教材(豆電球)　　　　 \120
社会科資料集　　　　　　\580

そしてシート２の２学期の支出は以下のようになっていたとします。

　　　　項目　　　　 　　　金額
国語テスト(２学期)　　　　\280
算数テスト(２学期)　　　　 \280
計算ドリル(下)　　　　　　 \450
理科教材(インゲン豆)　　 \160
図工教材(紙粘土)　　　　\280

そしてシート３の３学期の支出は以下のようになっていたとします。

　　　　項目　　　　 　　　金額
国語テスト(３学期)　　　　\280
算数テスト(３学期)　　　　 \280
家庭科調理実習費 　　　　\180
理科教材(電池）　　　　　　 \100
図工教材(版画)　　　　　　\320

そして、最後のシート４「会計報告書」には、シート１～シート３までの支出一覧を表にまとめたいのです。

その時の希望の形は添付画像の通りです。

『国語テスト(１学期）\280』や『国語テスト（２学期）\280』を『国語テスト（1～２学期） \560』
といった具合にまとめられるものはまとめ、
『社会科資料集 \580』のように1年間で1回しか買う必要が無いまとめられない物は、
そのまま会計報告書の支出欄に掲載できるようにしたいと思っています。

シート１～シート３までの入力さえきちんと行えば、自動的にシート４の会計報告書が出来上がる。
そんなことは可能でしょうか？

セルの位置は特に決まっていません。
あと、作業シートを設けることも問題ありません。
お知恵を貸して頂けると助かります。
どうぞ、よろしくお願い致します。

回答No.3

tom04

こんばんは！
VBAでの一例です。

↓の画像のように左側がSheet1～Sheet3のセル配置、そしてSheet4は右側のように
3行目が項目行になっているという前提です。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, k As Long, cnt As Long, endRow As Long
Dim c As Range, str As String, buf As String, wS As Worksheet, wSs As Worksheet
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set wSs = Worksheets(Worksheets.Count)
With Worksheets(4)
On Error Resume Next
Application.ScreenUpdating = False
endRow = .Cells(Rows.Count, "A").End(xlUp).Row
If endRow > 3 Then
Range(.Cells(4, "A"), .Cells(endRow, "B")).ClearContents
End If
cnt = 3
For k = 1 To 3
Set wS = Worksheets(k)
For i = 2 To Worksheets(k).Cells(Rows.Count, "A").End(xlUp).Row
If InStr(StrConv(wS.Cells(i, "A"), vbNarrow), "(") > 0 Then
str = Left(wS.Cells(i, "A"), InStr(StrConv(wS.Cells(i, "A"), vbNarrow), "(") - 1)
Else
str = wS.Cells(i, "A")
End If
If WorksheetFunction.CountIf(wSs.Range("A:A"), str) = 0 Then
cnt = cnt + 1
wSs.Cells(cnt, "A") = str
End If
Next i
Next k
wSs.Range("A:A").Replace what:="(", replacement:="", lookat:=xlPart

For i = 4 To wSs.Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To 3
Set wS = Worksheets(k)
Set c = wS.Range("A:A").Find(what:=wSs.Cells(i, "A"), LookIn:=xlValues, lookat:=xlPart)
If Not c Is Nothing Then
If InStr(c, "(") > 0 Or InStr(c, "（") > 0 Then
cnt = InStr(c, "(") + 1
str = Mid(c, cnt, Len(c) - cnt)
buf = buf & str & "・"
.Cells(i, "B") = .Cells(i, "B") + c.Offset(, 1)
Else
.Cells(i, "A") = wSs.Cells(i, "A")
.Cells(i, "A").Offset(, 1) = c.Offset(, 1)
End If
End If
Next k
.Cells(i, "A") = wSs.Cells(i, "A") & vbCrLf & "(" & Left(buf, Len(buf) - 1) & ")"
buf = ""
Next i
.Cells(Rows.Count, "A").End(xlUp).Offset(2) = "支出合計"
.Cells(Rows.Count, "B").End(xlUp).Offset(2) = WorksheetFunction.Sum(.Range("B:B"))
.Range("A:A").ColumnWidth = 100
.Columns.AutoFit
End With
Application.DisplayAlerts = False
wSs.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub 'この行まで

※　関数でないので、データ変更があるたびにマクロを実行する必要があります。
※　1行・1列でもレイアウトが違うとまったく意図しない動きになりますので、
画像通りの配置でマクロを試してみてください。m(_ _)m

お礼

お礼が遅すぎて、申し訳ございませんでした。
ありがとうございました。