ＥＸＣＥＬで家計簿作成 カテゴリごとに金額の合計を算出する方法がわかりません

質問

EXCELマクロ初心者です。EXCEL2002で家計簿を作成しています。
　Ａ　　　Ｂ　　Ｃ
１内科　　医者　１０００
２弁当　　食費　　８００
３歯医者　医者　　５００
４おにぎり食費　　２００
５　　　　end
上記内容をＥＸＣＥＬに入力します。
Ａ欄は品目、Ｂ欄はカテゴリ、Ｃ欄は金額を入力します。
これを、マクロを使ってＢ欄ごとに合計金額を算出したいのです。
完成イメージは以下のとおりです。

医者　１５００
食費　１０００

因みに、以下のようにコーディングしてみましたが、うまくいきません。
Sub ボタン1_Click()
Dim mykategori
Dim myisyakingaku
Dim mysyokuhikingaku
Range("b1").Select
Do Until ActiveCell.Value = "end"
mykategori = ("b1")
If mykategori = "医者" Then
myisyakingaku　= myisyakingaku+ ("c1")・・・(1)
ElseIf mykategori = "食費" Then
mysyokuhikingaku = mysyokuhikingaku + ("C2")・・・(2)
End If
ActiveCell.Offset(1).Select

Range("D1") = myisyakingaku・・・(3)
Range("D2") = mysyokuhikingaku・・・(3)
Loop
End Sub

(1)(2)が間違っているのはよくわかっているのですが、
金額の座標軸を１つずつ下にずらす方法がわかりません。
座標軸を１つずつずらす方法を教えて下さい。
そもそも、こんなコーディングしないよ！もっと良い方法があるよ！という場合は、上記のコーディングは無視してコディング例を教えていただきたいと思います。

なお、(3)は合計金額を仮表示するために空いている箇所に適当に
表示させるためにコーディングしたものです。
あまり気にしなくて結構です。

以上、宜しくお願い致します。

回答No.3

hallo-2007 · ベストアンサー

>金額の座標軸を１つずつ下にずらす方法がわかりません。
Cells(ActiveCell.Row, 3).Value
と記述する方法もあります。
IF文ですが　CASE文がわかりやすいかも
勉強の材料として
Range("D1").Value = 0
Range("D2").Value = 0
Range("b1").Activate
Do Until ActiveCell.Value = "end"
Select Case ActiveCell.Value
Case "医者"
Range("D1").Value = Range("D1").Value + Cells(ActiveCell.Row, 3).Value '・・・(1)
Case "食費"
Range("D2").Value = Range("D2").Value + Cells(ActiveCell.Row, 3).Value '・・・(2)
End Select
ActiveCell.Offset(1).Activate
Loop
End Sub

他方法ですが、この様な集計ならば
一般機能の　ピボットテーブル　或いは巻数で（SUMIFなど）で十分ですよ。

お礼

コーディングして実行したところ、
完成イメージ通りの結果が得られました。
ありがとうございます！

回答No.4

imogasi

こんなエクセルの処理を繰り返し法でやるより
（１）ピボットテーブル
（２）関数利用
などでやるのがよいと思う。
ーー
同じ繰り返し法でも、下記のやり方をやってみて、よさを勉強して。
質問者のいう「カテゴリ」が表（コードのおもて）に出ないが、存在するだけ集計するよ。
例データ
A列　　　B列　　　C列
内科 医者 1000
弁当 食費 800
歯医者 医者 500
おにぎり 食費 200
靴下 衣類 500
パンツ 衣類 1000
会食 交際費 4000
授業料 学費 30000
授業料 学費 40000
弁当 食費 1000
データの終わりにENDなど入れないものだ。
ーー
標準モジュールに
Sub test01()
d = Range("A65536").End(xlUp).Row
d2 = Range("H65536").End(xlUp).Row
For i = 2 To d
For k = 1 To d2
If Cells(i, "B") = Cells(k, "H") Then
Cells(k, "I") = Cells(k, "I") + Cells(i, "C")
GoTo p1
Else
End If
Next k
d2 = d2 + 1
Cells(d2, "H") = Cells(i, "B")
Cells(d2, "I") = Cells(i, "C")
p1:
Next i
End Sub
ーーー
結果
H列　I列
医者 1500
食費 2000
衣類 1500
交際費 4000
学費 70000

回答No.2

n-jun

提示されたコードを修正するのなら、

Sub ボタン1_Click()
Dim mykategori As String
Dim myisyakingaku As Double
Dim mysyokuhikingaku As Double
Dim myrow As Long

myrow = 1
Do Until Range("B" & myrow).Value = "end"
mykategori = Range("B" & myrow).Value
If mykategori = "医者" Then
myisyakingaku = myisyakingaku + Range("C" & myrow).Value
ElseIf mykategori = "食費" Then
mysyokuhikingaku = mysyokuhikingaku + Range("C" & myrow).Value
End If
myrow = myrow + 1
Loop

Range("D1").Value = "医者"
Range("E1").Value = myisyakingaku
Range("D2").Value = "食費"
Range("E2").Value = mysyokuhikingaku
End Sub
こんな感じではないかと。

お礼

コーディングして実行したことろ、医者、食費等の見出しが付与されるのですね。見易いです。
ありがとうございました！

回答No.1

n-jun

Ｂ列最後の”end”は消して下さい。
結果はＥ列・Ｆ列に出します。

Sub　test()
　Dim　Dic　As　Object
　Dim　i　As　Long
　Dim　v　As　Variant

　Set　Dic　=　CreateObject("Scripting.Dictionary")

　With　ActiveSheet
　　　　　　v　=　.Range(.Range("B1"),　.Cells(Rows.Count,　3).End(xlUp)).Value
　　　　　　For　i　=　1　To　UBound(v,　1)
　　　　　　　　　　Dic(v(i,　1))　=　Dic(v(i,　1))　+　v(i,　2)
　　　　　　Next
　　　　　　.Range("E1").Resize(Dic.Count,　1).Value　=　Application.Transpose(Dic.keys)
　　　　　　.Range("F1").Resize(Dic.Count,　1).Value　=　Application.Transpose(Dic.items)
　End　With
　Set　Dic　=　Nothing
　Erase　v
End　Sub
ご参考程度に。

お礼

コーディングして実行したところ、イメージ通りの結果が得られました。ただ、私がこのようなコーディングをするにはまだまだスキル不足かなと感じました。ＶＢＡの本を片手に解析し、理解を深めたいと考えています。
ありがとうございました！