よねさんのWordとExcelの小部屋｜Excel(エクセル)講座の総目次｜Excel(エクセル)実用編：目次｜家計簿の作成(VBA)

Excel(エクセル)実用編：家計簿の作成(VBA)

家計簿をエクセルで作成する例です。処理にはマクロ(VBA)を利用しています。

スポンサードリンク

はじめに	データの入力&訂正	並べ替え	月別集計
項目別集計	年間集計	購入店別集計
ダウンロード　kakei_D5.xls(約200KB)

はじめに

家計簿の作成をVBAで行う例です。
この例は主に、Excelの一般機能である、フィルタオプションの設定や集計機能を利用しています。
コードはマクロの自動記録にちょっと手を入れた程度のものですので理解しやすいと思います。
この家計簿は、ひとつのブックに1年分（1月～12月）のデータを入力して使います。
データを入力するだけで、後の操作はボタンをクリックするだけで集計ができます。
集計は月別、年間、項目別、購入店別の4パターンを準備しています。
なお、「入力表」シートのデータを直接変更しても動きます。
2006.7.14　改修しました。
2010.2.24　コードを見直して修正しました。

【項目の設定】
- 『項目の変更』ボタンから変更・追加のフォームを表示します。
【データの入力】
- 『追加&訂正』ボタンから「データの追加&訂正」フォームを表示します。
  入力順は、日付順でなくてもかまいません。ランダムに入力しても、後で並べ替えが可能です。
- 『並べ替え』ボタンでデータを並べ替えます。
  日付と項目をキーとして昇順に並べ替えます。
【月別集計】
- 入力データから、同じ月のデータを抽出して計算します。
- 『入力表』シートの上から順番で表示されます。『並べ替え』をしてから集計します。
【項目別集計】
- 入力データから、同じ項目のデータを抽出して計算します。
- 『入力表』シートの上から順番で表示されます。『並べ替え』をしてから集計します。
【年間集計】
- 1年間を各月、各項目ごとにまとめて集計します。
- 収入金額と支出金額の入力がある項目を検索して、集計します。

データ入力･訂正　　　　 Topへ

『入力表』シートがメインのシートになります。
- データの入力順は日付順でなくてもかまいません。入力し忘れたら、気づいたときに後ろに追加します。
- 後で、並べ替えが可能になっています。

【追加・訂正】ボタンをクリックすると、『データの追加&訂正』フォームが表示されます。

データの追加ができる状態で表示されます。
1. データNo
  - 入力済みデータの次のNoが入力されています。
  - 入力済みのデータを訂正する場合は、このNoを修正します。
2. 年月日
  - パソコンの日付が表示されます。
  - 異なる日付のデータの場合は、日付を修正します。「10/2」のように「/」で区切って入力します。
3. 項目名
  - コンボボックスになっていますので『▼』ボタンをクリックして、該当するものを選択します。
  - 表示される項目名は『項目一覧表』シートで登録されたものです。
4. 収入、支出
  - いずれかに金額を入力します。
5. 適用
  - 明細などを、後で分かるように入力します。
6. 【追加・訂正】ボタン
  - 『入力表』シートに入力されます。引き続いてデータの入力が可能です。
7. 【終了】ボタン
  - 入力済みデータに罫線が引かれ『データの追加&訂正』フォームが閉じます。

ユーザーフォームのコードです。

ユーザーフォームの初期化

Private Sub UserForm_Initialize()
　　Dim r As Long
　　Dim myDCount As Long, myDRange As String
　　Dim 最終行 As Long, 項目行 As Long

　　　　Application.ScreenUpdating = False
　　　　　　最終行 = Worksheets("入力表").Range("B" & Rows.count).End(xlUp).Row
　　　　　　TBoxNo.Value = 最終行 - 10 + 1
　　　　　　TBox年月日.Value = Date
　　　　　　TBox収入.Value = Null
　　　　　　TBox支出.Value = Null

　　　　　　項目行 = Worksheets("項目一覧表").Range("B" & Rows.count).End(xlUp).Row
　　　　　　CBox項目.RowSource = "項目一覧表!B3:B" & 項目行
　　　　　　項目行 = Worksheets("項目一覧表").Range("G" & Rows.count).End(xlUp).Row
　　　　　　CBox購入店.RowSource = "項目一覧表!G3:G" & 項目行
　　　　　　TBox適用.Value = Null
　　　　Application.ScreenUpdating = True
　　　　　　Worksheets("入力表").Activate
　　　　　　Cells(最終行 + 1, 2).Select
End Sub

コマンドボタンで実行するコードです。

’----[追加・修正]ボタンで実行
Private Sub CButtonOK_Click()
　　Dim r As Long, 最終行 As Long, 項目行 As Long
　　Dim re As String
　　　　r = TBoxNo.Value + 10
　　　　最終行 = Worksheets("入力表").Range("B" & Rows.count).End(xlUp).Row
　　　　If r <= 最終行 Then
　　　　　　re = MsgBox("訂正" & " " & "すでにデータが入力されています。" & Chr(13) & _
　　　　　　　　Chr(13) & "データを置き換えます。　本当に良いですか?　", _
　　　　　　　　Buttons:=vbYesNo + vbExclamation, Title:="注意!!")
　　　　　　If re = vbYes Then
　　　　　　　　With Worksheets("入力表")
　　　　　　　　　　.Cells(r, 2).Activate
　　　　　　　　　　.Cells(r, 1).Value = TBoxNo.Value
　　　　　　　　　　.Cells(r, 2).Value = TBox年月日.Value
　　　　　　　　　　.Cells(r, 3).Value = CBox項目.Value
　　　　　　　　　　.Cells(r, 4).Value = TBox収入.Value
　　　　　　　　　　.Cells(r, 5).Value = TBox支出.Value
　　　　　　　　　　.Cells(r, 6).Value = TBox適用.Value
　　　　　　　　　　.Cells(r, 7).Value = CBox購入店.Value
　　　　　　　　End With
　　　　　　　　データクリア
　　　　　　　　Exit Sub
　　　　　　End If
　　　　　　データクリア
　　　　　　Exit Sub
　　　　End If
　　　　If r >= 最終行 + 1 Then
　　　　　　r = 最終行 + 1
　　　　End If
　　　　With Worksheets("入力表")
　　　　　　　.Cells(r, 1).Value = TBoxNo.Value
　　　　　　　.Cells(r, 2).Value = TBox年月日.Value
　　　　　　　.Cells(r, 3).Value = CBox項目.Value
　　　　　　　.Cells(r, 4).Value = TBox収入.Value
　　　　　　　.Cells(r, 5).Value = TBox支出.Value
　　　　　　　.Cells(r, 6).Value = TBox適用.Value
　　　　　　　.Cells(r, 7).Value = CBox購入店.Value
　　　　End With
　　　　データクリア
End Sub
’--------------
Sub データクリア()
　　Dim 最終行 As Long
　　　　最終行 = Worksheets("入力表").Range("B" & Rows.count).End(xlUp).Row
　　　　Worksheets("入力表").Activate
　　　　Cells(最終行 + 1, 2).Select

　　　　TBoxNo.Value = 最終行 - 10 + 1
　　　　TBox年月日.Value = Date
　　　　TBox収入.Value = Null
　　　　TBox支出.Value = Null
　　　　TBox適用.Value = Null
　　　　CBox項目.Value = Null
　　　　CBox購入店.Value = Null
End Sub
’---------------
Private Sub CButtonキャンセル_Click()
　　Dim 最終行 As Long
　　　　With Worksheets("入力表")
　　　　　　最終行 = .Range("B" & Rows.count).End(xlUp).Row
　　　　　　If 最終行 < 11 Then 最終行 = 11
　　　　　　.Range("A11:G" & 最終行).Interior.ColorIndex = 34
　　　　　　.Range("A11:G" & 最終行).Borders.Weight = xlThin
　　　　　　.Range("A11:G" & 最終行).Borders.ColorIndex = 11
　　　　End With
　　　　Me.Hide
End Sub

テキストボックスが変更されたときに表示を変更

Private Sub TBoxNo_afterUpdate()
　　Dim データNo As Long, 最終行 As Long, r As Long
　　　　データNo = TBoxNo.Value
　　　　最終行 = Worksheets("入力表").Range("B" & Rows.count).End(xlUp).Row

　　　　If データNo <= 最終行 - 10 Then
　　　　　　r = データNo + 10
　　　　　　With Worksheets("入力表")
　　　　　　　　.Activate
　　　　　　　　.Cells(r, 2).Select
　　　　　　　　TBoxNo.Value = .Cells(r, 1).Value
　　　　　　　　TBox年月日.Value = .Cells(r, 2).Value
　　　　　　　　CBox項目.Value = .Cells(r, 3).Value
　　　　　　　　TBox収入.Value = Format(.Cells(r, 4).Value, "###,###")
　　　　　　　　TBox支出.Value = Format(.Cells(r, 5).Value, "###,###")
　　　　　　　　TBox適用.Value = .Cells(r, 6).Value
　　　　　　　　CBox購入店.Value = .Cells(r, 7).Value
　　　　　　End With
　　　　　　Exit Sub
　　　　End If

　　　　If データNo > 最終行 - 10 Then
　　　　　　データNo = 最終行 - 9
　　　　　　TBoxNo.Value = データNo
　　　　　　データクリア
　　　　End If
End Sub
’------------------
Private Sub TBox収入_afterUpdate()
　　Dim 収入 As Long
　　　　収入 = TBox収入.Value
　　　　TBox収入.Value = Format(収入, "###,###")
End Sub
’------------------
Private Sub TBox支出_afterUpdate()
　　Dim 支出 As Long
　　　　支出 = TBox支出.Value
　　　　TBox支出.Value = Format(支出, "###,###")
End Sub

並べ替え　　　　 Topへ

入力したデータが、日付順に並んでいない時に【並べ替え】ボタンをクリックすると、【日付】と【項目名】をキーとして、昇順に並べ替えます。

並べ替え前：No.10とNo.11のデータの位置が変わります。
日付順に並べ変わりました。
ここで、Noも日付順で連続した値に変更されます。

並べ替えのコードです。

標準モジュールに書きます。

Sub 並べ替え() '入力表のデータを並べ替える
　　Dim lastRow As Long, i As Long, lastClm As Integer
　　　　With Worksheets("入力表")
　　　　　　lastRow = .Range("B" & Rows.count).End(xlUp).Row
　　　　　　lastClm = .Cells(10, Columns.count).End(xlToLeft).Column

　　　　　　 .Range(.Cells(11, 1), .Cells(lastRow, lastClm)).Sort _
　　　　　　　　　Key1:=Range("B11"), _
　　　　　　　　　Order1:=xlAscending, Key2:=Range("C11"), _
　　　　　　　　　Order2:=xlAscending, _
　　　　　　　　　Header:=xlGuess, _
　　　　　　　　　OrderCustom:=1, _
　　　　　　　　　MatchCase:=False, _
　　　　　　　　　Orientation:=xlTopToBottom, _
　　　　　　　　　SortMethod:=xlPinYin, _
　　　　　　　　　DataOption1:=xlSortNormal, _
　　　　　　　　　DataOption2:=xlSortNormal

　　　　　　lastRow = .Range("B" & Rows.count).End(xlUp).Row
　　　　　　For i = 11 To lastRow
　　　　　　　　.Cells(i, 1).Value = i - 10
　　　　　　Next i
　　　　　　.Activate
　　　　　　.Cells(lastRow, 1).Select
　　　　End With
End Sub

月別集計　　　　 Topへ

『入力表』シートの【抽出・集計】ボタンをクリックすると集計のフォームが表示されます。
コンボボックスで集計する月を選択して、【月別抽出・集計】ボタンをクリックします。
集計例です。
7月分のデータが抽出されました。
【項目別集計】ボタンをクリックすると、集計機能による集計が実行されます。
この時、項目名で並べ替えてから集計が実行されます。
【集計の解除】ボタンで集計が解除されますが、項目順での並べ替えがされたままの状態になります。

月別集計のコード

表示データを削除後、フィルタオプションでデータを抽出しています。
合計行は計算式を入力しています。

Private Sub CommandButton1_Click() '月別集計

　　Dim A, 月, 計算月 As Integer
　　Dim i As Long, j As Long, count As Long
　　Dim rangeA As Range
　　Dim 最終行番号 As Long, 最終列番号 As Long, 入力最終行 As Long
　　Dim 月日 As Date
　　Dim 残高 As Long

　　Application.ScreenUpdating = False
　　　　With Worksheets("月別集計表")
　　　　　　.Range("A1").Value = ""
　　　　　　.Range("A2").Formula = "=MONTH(入力表!B11)=" & Val(CBox月数.Value)
　　　　　　Label1.Caption = "抽出中........　　"
　　　　　　Frm月別集計.Repaint

　　　　　　最終行番号 = .Range("B" & Rows.count).End(xlUp).Row
　　　　　　.Activate
　　　　　　.Range("B5").RemoveSubtotal

　　　　　　.Range("B6:G" & 最終行番号 + 1).Delete shift:=xlUp

　　　　　　入力最終行 = Sheets("入力表").Range("B" & Rows.count).End(xlUp).Row
　　　　　　Sheets("入力表").Range("A10:G" & 入力最終行).AdvancedFilter _
　　　　　　　　Action:=xlFilterCopy, _
　　　　　　　　CriteriaRange:=.Range("A1:A2"), _
　　　　　　　　CopyToRange:=.Range("B5:G5"), _
　　　　　　　　Unique:=False

　　　　　　最終行番号 = .Range("B" & Rows.count).End(xlUp).Row

　　　　'　計算(合計)
　　　　　　 If 最終行番号 = 5 Then 最終行番号 = 6
　　　　　　.Range("C" & 最終行番号 + 1).Value = "合　計"
　　　　　　.Range("D" & 最終行番号 + 1).FormulaR1C1 = "=SUM(R6C4:R[-1]C4)"
　　　　　　.Range("E" & 最終行番号 + 1).FormulaR1C1 = "=SUM(R6C5:R[-1]C5)"

　　　　　　.Range("B6:G" & 最終行番号 + 1).Borders.Weight = xlThin
　　　　　　.Range("B6:B" & 最終行番号 + 1).NumberFormat = "mm月dd日"
　　　　　　.Range("D6:E" & 最終行番号 + 1).NumberFormat = "#,##0"
　　　　　　.Range("B6:G" & 最終行番号 + 1).Interior.ColorIndex = 36
　　　　　　.Range("B6:G" & 最終行番号).Interior.ColorIndex = 34

　　　　　　.Activate
　　　　　　.Range("B" & 最終行番号 + 1).Select
　　　　End With
　　Application.ScreenUpdating = True
　　Me.Hide
End Sub

項目別集計　　　　 Topへ

『入力表』シートの【抽出・集計】ボタンをクリックすると集計のフォームが表示されます。
コンボボックスで集計する項目を選択して、【項目別抽出】ボタンをクリックします。
『食費』の集計例です。
フィルタオプションの設定で抽出しています。コードは上と同様ですので省略します。

年間集計　　　　 Topへ

『入力表』シートの【抽出・集計】ボタンをクリックすると集計のフォームが表示されます。
【年間集計】ボタンをクリックします。
【収入】と【支出】に分けて表示されます。
- 金額の入力がない項目は無視されます。(表示しません。)

コードは単純にFor～Nextのループで計算しています。(実行速度は遅いです)

簡単な命令文のみで作成しています。ループやIF文がややこしいことになっていますがお許しください。
速度が遅い場合は配列を利用すればかなり改善できますので、次項のような感じでご自身で作成してみてください。

Private Sub CommandButton4_Click() '年間集計
　　Label1.Caption = "集計中........　　"
　　Frm月別集計.Repaint

Dim 月(1 To 12), 計算月 As Integer
Dim i As Long, j As Long, k As Long, count1 As Integer, count2 As Integer
Dim データ行 As Long, データ数 As Long, 最終行 As Long
Dim 収入金額 As Long, 支出金額 As Long
Dim 収入項目 As String, 支出項目 As String
Dim 項目1 As String, 項目3 As String
Dim 月1 As String
Dim 収入項目名(1 To 20) As String
Dim 収入(1 To 20, 1 To 20) As Double, 支出(1 To 20, 1 To 20) As Double
Dim 収入1 As Double, 支出1 As Double, x As Double
Dim 支出項目名1(1 To 20) As String
Dim 合計 As Range
Dim checker As Integer, 比較値 As Integer
Dim 行頭 As Integer

　　Application.ScreenUpdating = False

　　データ行 = Worksheets("入力表").Range("B" & Rows.count).End(xlUp).Row
　　データ数 = データ行 - 10

　　'----データ表のクリア
　　　　With Worksheets("年間集計")
　　　　　　最終行 = .Range("B" & Rows.count).End(xlUp).Row
　　　　　　If 最終行 < 3 Then 最終行 = 3
　　　　　　　　.Range("B3:O" & 最終行).Delete
　　　　　　End With

　　'----収入のあった項目名を取得
　　　　count1 = 0
　　　　For i = 1 To データ数
　　　　　　収入金額 = Worksheets("入力表").Range("D" & i + 10).Value
　　　　　　If 収入金額 > 0 Then
　　　　　　　　収入項目 = Worksheets("入力表").Range("C" & i + 10).Value
　　　　　　　　If count1 = 0 Then
　　　　　　　　　　count1 = 1
　　　　　　　　　　収入項目名(count1) = 収入項目
　　　　　　　　End If
　　　　　　　　checker = 0
　　　　　　　　'----項目名が既出か否かを判定
　　　　　　　　For j = 1 To count1
　　　　　　　　　　比較値 = StrComp(収入項目名(j), 収入項目)
　　　　　　　　　　If 比較値 = 0 Then
　　　　　　　　　　　　checker = 1
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　Next j
　　　　　　　　'----項目名が無いときは追加する
　　　　　　　　If checker = 0 Then
　　　　　　　　　　count1 = count1 + 1
　　　　　　　　　　収入項目名(count1) = 収入項目
　　　　　　　　End If
　　　　　　End If
　　　　Next i

　　For i = 1 To 12
　　　　月(i) = i
　　　　For j = 1 To count1
　　　　　　　For k = 11 To データ行
　　　　　　　　　項目1 = Worksheets("入力表").Cells(k, 3).Value
　　　　　　　　　月1 = Worksheets("入力表").Cells(k, 2).Value
　　　　　　　　　月1 = Month(月1)
　　　　　　　　　If 月(i) = 月1 And 項目1 = 収入項目名(j) Then
　　　　　　　　　　　収入1 = Worksheets("入力表").Cells(k, 4).Value
　　　　　　　　　　　収入(i, j) = 収入(i, j) + 収入1
　　　　　　　　　End If
　　　　　　　Next k
　　　　Next j

　　　　For j = 1 To count1
　　　　　　Worksheets("年間集計").Cells(j + 4, 2).Value = 収入項目名(j)
　　　　　　Worksheets("年間集計").Cells(j + 4, i + 2).Value = 収入(i, j)
　　　　Next j
　　Next i

　　With Worksheets("年間集計")
　　　　　.Cells(4, 15).Value = "合　計"
　　　　　For i = 1 To count1
　　　　　　　x = WorksheetFunction.Sum(.Range(.Cells(4 + i, 3), .Cells(4 + i, 15)))
　　　　　　　.Cells(4 + i, 15).Value = x
　　　　　Next i
　　　　　.Cells(count1 + 6, 2).Value = "合　計"

　　　　　For i = 3 To 15
　　　　　　　x = WorksheetFunction.Sum(.Range(.Cells(4 + count1, i), .Cells(5, i)))
　　　　　　　.Cells(count1 + 6, i).Value = x
　　　　　Next i

　　　　　'----表の作成
　　　　　For i = 3 To 14
　　　　　　　.Cells(4, i).Value = i - 2 & "月"
　　　　　Next i
　　　　　With .Range("B3")
　　　　　　　.Value = "収入"
　　　　　　　.Font.Size = 20
　　　　　　　.Font.Bold = True
　　　　　　　.Font.Name = "HGP行書体"
　　　　　　　.Font.ColorIndex = 10
　　　　　End With

　　　　　.Range("B4:O" & count1 + 6).Borders.Weight = xlThin
　　　　　.Range("C5:O" & count1 + 6).NumberFormat = "#,##0"
　　　　　.Range("B4:O" & count1 + 6).Interior.ColorIndex = 36
　　　　　.Range("B4:O4").Interior.ColorIndex = 40
　　　　　.Range("B4:O4").HorizontalAlignment = xlCenter
　　　　　.Range("C5:N" & count1 + 5).Interior.ColorIndex = 34
　　End With

　　'----支出のあった項目名を取得
　　　　count2 = 0
　　　　For i = 1 To データ数
　　　　　　支出金額 = Worksheets("入力表").Range("E" & i + 10).Value
　　　　　　If 支出金額 > 0 Then
　　　　　　　　支出項目 = Worksheets("入力表").Range("C" & i + 10).Value
　　　　　　　　If count2 = 0 Then
　　　　　　　　　　count2 = 1
　　　　　　　　　　支出項目名1(count2) = 支出項目
　　　　　　　　End If
　　　　　　　　checker = 0
　　　　　　　　For j = 1 To count2
　　　　　　　　　　比較値 = StrComp(支出項目名1(j), 支出項目)
　　　　　　　　　　　　If 比較値 = 0 Then
　　　　　　　　　　　　　　checker = 1
　　　　　　　　　　　　　　Exit For
　　　　　　　　　　　　End If
　　　　　　　　Next j
　　　　　　　　If checker = 0 Then
　　　　　　　　　　count2 = count2 + 1
　　　　　　　　　　支出項目名1(count2) = 支出項目
　　　　　　　　End If
　　　　　　End If
　　　　Next i

　　　　For i = 1 To 12
　　　　　　月(i) = i
　　　　　　For j = 1 To count2
　　　　　　　　For k = 11 To データ行
　　　　　　　　　　項目3 = Worksheets("入力表").Cells(k, 3).Value
　　　　　　　　　　月1 = Worksheets("入力表").Cells(k, 2).Value
　　　　　　　　　　月1 = Month(月1)
　　　　　　　　　　If 月(i) = 月1 And 項目3 = 支出項目名1(j) Then
　　　　　　　　　　　　支出1 = Worksheets("入力表").Cells(k, 5).Value
　　　　　　　　　　　　支出(i, j) = 支出(i, j) + 支出1
　　　　　　　　　　End If
　　　　　　　　Next k
　　　　　　Next j

　　　　　　行頭 = count1 + 4 + 6
　　　　　　For j = 1 To count2
　　　　　　　　Worksheets("年間集計").Cells(j + 行頭, 2).Value = 支出項目名1(j)
　　　　　　　　Worksheets("年間集計").Cells(j + 行頭, i + 2).Value = 支出(i, j)
　　　　　　Next j
　　　　Next i

　　　　With Worksheets("年間集計")
　　　　　　.Cells(行頭, 15).Value = "合　計"
　　　　　　For i = 1 To count2
　　　　　　　　x = WorksheetFunction.Sum(.Range(.Cells(行頭 + i, 3), .Cells(行頭 + i, 15)))
　　　　　　　　.Cells(行頭 + i, 15).Value = x
　　　　　　Next i
　　　　　　.Cells(count2 + 行頭 + 2, 2).Value = "合　計"

　　　　　　For i = 3 To 15
　　　　　　　　x = WorksheetFunction.Sum(.Range(.Cells(行頭 + count2, i), .Cells(行頭, i)))
　　　　　　　　.Cells(count2 + 行頭 + 2, i).Value = x
　　　　　　Next i

　　　　　　'----表の作成
　　　　　　.Cells(行頭, 2).Resize(, 14).Value = .Range("B4:O4").Value
　　　　　　.Cells(行頭, 2).Resize(, 14).Interior.ColorIndex = 40
　　　　　　.Cells(行頭, 2).Resize(, 14).HorizontalAlignment = xlCenter

　　　　　　.Cells(行頭 - 1, 2).Value = "支出"
　　　　　　.Cells(行頭 - 1, 2).Font.Size = 20
　　　　　　.Cells(行頭 - 1, 2).Font.Bold = True
　　　　　　.Cells(行頭 - 1, 2).Font.Name = "HGP行書体"
　　　　　　.Cells(行頭 - 1, 2).Font.ColorIndex = 10

　　　　　　.Range(.Cells(行頭, 2), .Cells(行頭 + count2 + 2, 15)).Borders.Weight = xlThin
　　　　　　.Range(.Cells(行頭 + 1, 3), .Cells(行頭 + count2 + 2, 15)).NumberFormat = "#,##0"
　　　　　　.Range(.Cells(行頭 + 1, 3), .Cells(行頭 + count2 + 2, 14)).Interior.ColorIndex = 34
　　　　　　.Range(.Cells(行頭 + 1, 2), .Cells(行頭 + count2 + 2, 2)).Interior.ColorIndex = 36
　　　　　　.Range(.Cells(行頭 + 1, 15), .Cells(行頭 + count2 + 2, 15)).Interior.ColorIndex = 36
　　　　　　.Range(.Cells(行頭 + count2 + 2, 2), .Cells(行頭 + count2 + 2, 15)).Interior.ColorIndex = 36

　　　　　　.Activate
　　　　　　.Cells(1, 1).Select
　　　　End With
　　　　Application.ScreenUpdating = True
　　　　Label1.Caption = "集計が終わりました"
　　　　Me.Hide
End Sub

配列とDictionaryを利用した場合の例です。
なお、このコードでは値の書き出しだけで書式と合計は省略しています。(やっつけ仕事でちょっといい加減ですが・・・）

ダウンロード　kakei_D6.xls(約200KB)

Sub y_syukei()
　　Dim myDic As Object, myKey, myItem
　　Dim myVal, myVal2, myVal3, myVal4(1000, 12), myVal5(1000, 12)
　　Dim i As Long, j As Long, cnt As Long, f As Long

　　Set myDic = CreateObject("Scripting.Dictionary")
　　' ---元データを配列に格納
　　With Worksheets("入力表")
　　　　myVal = .Range("B11：G" & .Range("B" & Rows.count).End(xlUp).Row).Value
　　End With
　　' **********myDicへ収入データを格納***********
　　For i = 1 To UBound(myVal, 1)
　　　　myVal2 = Month(myVal(i, 1)) & "_" & myVal(i, 2)
　　　　If Not myVal2 = "_" And myVal(i, 3) > 0 Then
　　　　　　If Not myDic.exists(myVal2) Then
　　　　　　　　myDic.Add myVal2, myVal(i, 3)
　　　　　　Else
　　　　　　　　myDic(myVal2) = myDic(myVal2) + myVal(i, 3)
　　　　　　End If
　　　　End If
　　Next
　　' ---Key,Itemの書き出し
　　myKey = myDic.keys
　　myItem = myDic.items
　　For i = 0 To UBound(myKey)
　　　　myVal3 = Split(myKey(i), "_")
　　　　f = 0
　　　　For j = 1 To cnt
　　　　　　If myVal4(j, 0) = myVal3(1) Then
　　　　　　　　f = j
　　　　　　　　Exit For
　　　　　　End If
　　　　Next j
　　　　If f = 0 Then cnt = cnt + 1: f = cnt
　　　　myVal4(f, 0) = myVal3(1)
　　　　myVal4(f, myVal3(0)) = myItem(i)
　　Next
　　Set myDic = Nothing

　　' **********myDicへ支出データを格納***********
　　Set myDic = CreateObject("Scripting.Dictionary")

　　For i = 1 To UBound(myVal, 1)
　　　　myVal2 = Month(myVal(i, 1)) & "_" & myVal(i, 2)
　　　　If Not myVal2 = "_" And myVal(i, 4) > 0 Then
　　　　　　If Not myDic.exists(myVal2) Then
　　　　　　　　myDic.Add myVal2, myVal(i, 4)
　　　　　　Else
　　　　　　　　myDic(myVal2) = myDic(myVal2) + myVal(i, 4)
　　　　　　End If
　　　　End If
　　Next
　　' ---Key,Itemの書き出し
　　myKey = myDic.keys
　　myItem = myDic.items
　　cnt = 0
　　For i = 0 To UBound(myKey)
　　　　　myVal3 = Split(myKey(i), "_")
　　　　　f = 0
　　　　　For j = 1 To cnt
　　　　　　　If myVal5(j, 0) = myVal3(1) Then
　　　　　　　　　f = j
　　　　　　　　　Exit For
　　　　　　　End If
　　　　　Next j
　　　　　If f = 0 Then cnt = cnt + 1: f = cnt
　　　　　myVal5(f, 0) = myVal3(1)
　　　　　myVal5(f, myVal3(0)) = myItem(i)
　　Next

　　'--------合計の計算と表の作成
　　Dim lastR As Long, lastR2 As Long
　　Application.ScreenUpdating = False
　　With Worksheets("年間集計")
　　　　lastR = .Range("B" & Rows.count).End(xlUp).Row
　　　　If lastR < 5 Then lastR = 5
　　　　.Range("3:" & lastR).Delete

　　　　.Range("B5").Resize(UBound(myVal4, 1) + 1, UBound(myVal4, 2) + 1).Value = myVal4
　　　　lastR = .Range("B" & Rows.count).End(xlUp).Row
　　　　.Range(lastR + 1 & ":2000").Delete

　　　　.Range("O5").Value = "合　計"

　　　　For i = 6 To lastR
　　　　　　.Cells(i, 15).Value = WorksheetFunction.Sum(.Range(.Cells(i, 3), .Cells(i, 15)))
　　　　Next i
　　　　.Range("B" & lastR + 1).Value = "合　計"
　　　　For i = 3 To 15
　　　　　　.Cells(lastR + 1, i).Value = WorksheetFunction.Sum(.Range(.Cells(6, i), .Cells(lastR, i)))
　　　　Next i

　　　　For i = 3 To 14
　　　　　　.Cells(5, i).Value = i - 2 & "月"
　　　　Next i
　　　　With .Range("B4")
　　　　　　.Value = "収入"
　　　　　　.Font.Size = 20
　　　　　　.Font.Bold = True
　　　　　　.Font.Name = "HGP行書体"
　　　　　　.Font.ColorIndex = 10
　　　　End With

　　　　.Range("B5:O" & lastR + 1).Borders.Weight = xlThin
　　　　.Range("C6:O" & lastR + 1).NumberFormat = "#,##0"
　　　　.Range("B5:O" & lastR + 1).Interior.ColorIndex = 36
　　　　.Range("B5:O5").Interior.ColorIndex = 40
　　　　.Range("B5:O5").HorizontalAlignment = xlCenter
　　　　.Range("C6:N" & lastR).Interior.ColorIndex = 34

　　'-----支出の表作成
　　　　lastR = .Range("B" & Rows.count).End(xlUp).Row
　　　　.Range("B" & Rows.count).End(xlUp).Offset(3, 0).Resize(UBound(myVal5, 1) + 1, UBound(myVal5, 2) + 1).Value = myVal5
　　　　lastR2 = .Range("B" & Rows.count).End(xlUp).Row
　　　　.Range(lastR2 + 1 & ":2000").Delete

　　　　.Cells(lastR + 3, 15).Value = "合　計"
　　　　For i = lastR + 4 To lastR2
　　　　　　.Cells(i, 15).Value = WorksheetFunction.Sum(.Range(.Cells(i, 3), .Cells(i, 15)))
　　　　Next i
　　　　.Range("B" & lastR2 + 1).Value = "合　計"
　　　　For i = 3 To 15
　　　　　　.Cells(lastR2 + 1, i).Value = WorksheetFunction.Sum(.Range(.Cells(lastR + 3, i), .Cells(lastR2, i)))
　　　　Next i

　　　　For i = 3 To 14
　　　　　　.Cells(lastR + 3, i).Value = i - 2 & "月"
　　　　Next i
　　　　With .Cells(lastR + 2, 2)
　　　　　　.Value = "支出"
　　　　　　.Font.Size = 20
　　　　　　.Font.Bold = True
　　　　　　.Font.Name = "HGP行書体"
　　　　　　.Font.ColorIndex = 10
　　　　End With

　　　　.Range(.Cells(lastR + 3, 2), .Cells(lastR2 + 1, 15)).Borders.Weight = xlThin
　　　　.Range(.Cells(lastR + 4, 3), .Cells(lastR2 + 1, 15)).NumberFormat = "#,##0"
　　　　.Range(.Cells(lastR + 3, 2), .Cells(lastR2 + 1, 15)).Interior.ColorIndex = 36
　　　　.Range(.Cells(lastR + 3, 2), .Cells(lastR + 3, 15)).Interior.ColorIndex = 40
　　　　.Range(.Cells(lastR + 3, 3), .Cells(lastR + 3, 15)).HorizontalAlignment = xlCenter
　　　　.Range(.Cells(lastR + 4, 3), .Cells(lastR2, 14)).Interior.ColorIndex = 34

　　　　.Activate
　　　　.Range("A3").Select

　　End With
　　Application.ScreenUpdating = True
End Sub

購入店別集計　　　　 Topへ

『入力表』シートの【抽出・集計】ボタンをクリックすると集計のフォームが表示されます。
コンボボックスで購入店を選択して、【購入店別抽出】ボタンをクリックします。
購入店別の集計がされます。

コードはフィルタオプションの設定を利用しています。上記月別と同様です。

月別とはフィルタオプションの設定の条件の書き方が異なっています。

Private Sub CommandButton5_Click() '購入店別集計
　　Dim 最終行番号 As Long, 入力最終行 As Long
　　Dim rangeA As Range
　　　　Application.ScreenUpdating = False
　　　　　　With Worksheets("購入店別集計表")
　　　　　　　　.Range("A1").Value = Worksheets("入力表").Range("G10").Value
　　　　　　　　.Range("A2").Formula = "=""=" & CBox購入店.Value & """"
　　　　　　　　Label1.Caption = "抽出中........　　"
　　　　　　　　Frm月別集計.Repaint

　　　　　　　　最終行番号 = .Range("B" & Rows.count).End(xlUp).Row
　　　　　　　　If 最終行番号 < 6 Then 最終行番号 = 6
　　　　　　　　.Activate
　　　　　　　　.Range("B6:G" & 最終行番号 + 1).Delete shift:=xlUp

　　　　　　　　入力最終行 = Sheets("入力表").Range("B" & Rows.count).End(xlUp).Row
　　　　　　　　Sheets("入力表").Range("A10:G" & 入力最終行).AdvancedFilter _
　　　　　　　　　　Action:=xlFilterCopy, _
　　　　　　　　　　CriteriaRange:=.Range("A1:A2"), _
　　　　　　　　　　CopyToRange:=.Range("B5:G5"), _
　　　　　　　　　　Unique:=False

　　　　　　　'　計算(合計)
　　　　　　　　最終行番号 = .Range("B" & Rows.count).End(xlUp).Row
　　　　　　　　If 最終行番号 < 6 Then 最終行番号 = 6

　　　　　　　　.Range("C" & 最終行番号 + 1).Value = "合　計"
　　　　　　　　.Range("D" & 最終行番号 + 1).FormulaR1C1 = "=SUM(R6C4:R[-1]C4)"
　　　　　　　　.Range("E" & 最終行番号 + 1).FormulaR1C1 = "=SUM(R6C5:R[-1]C5)"

　　　　　　　　.Range("B6:G" & 最終行番号 + 1).Borders.Weight = xlThin

　　　　　　　　.Range("B6:B" & 最終行番号 + 1).NumberFormat = "mm月dd日"
　　　　　　　　.Range("D6:E" & 最終行番号 + 1).NumberFormat = "#,##0"
　　　　　　　　.Range("B6:G" & 最終行番号 + 1).Interior.ColorIndex = 36
　　　　　　　　.Range("B6:G" & 最終行番号).Interior.ColorIndex = 34

　　　　　　　　.Activate
　　　　　　　　.Range("B" & 最終行番号 + 1).Select
　　　　　　End With

　　　　Application.ScreenUpdating = True
　　　　Me.Hide
End Sub

スポンサードリンク

よねさんのWordとExcelの小部屋｜Excel(エクセル)講座の総目次｜Excel(エクセル)実用編：目次｜家計簿の作成(VBA)

PageViewCounter
　 Counter
　Since2006/2/27

Excel(エクセル)実用編：家計簿の作成(VBA)

はじめに

データ入力･訂正 Topへ

並べ替え Topへ

月別集計 Topへ

項目別集計 Topへ