私は家計簿をつけるときにアプリを使っていますが、レシートの合計金額をそのまま一つの勘定科目で入力するということはしていません。

一つのレシートには食費や消耗品などが含まれているからです。

そのため一度エクセルで品物毎の金額を入力して費用科目を割り当てています。

しかし、この作業は続けていると結構面倒くさいのです。

「すこしでも楽になりたい。効率化したい。」と思いからVBAを使ってマクロを導入することにしました。

この記事では今回作成したマクロを紹介します。

Sub レシート集計()

    Dim 選択行 As Byte
    Dim 選択行2 As Byte
    Dim 行数 As Byte
    Dim 税率 As Single
    Dim 金額 As Integer
    Dim 開始行 As Byte
    Dim 終了行 As Byte
    Dim 検索条件 As String
    Dim 開始行2 As Byte
    
    
    
    Application.ScreenUpdating = False
    
    選択行 = ActiveCell.Row
    選択行2 = 選択行
    行数 = 1
    
    
'####　アクティブセルがB列でC列が空欄なら
    If ActiveCell = Cells(選択行, 2) And Cells(選択行, 3) = "" Then
    
        ActiveCell.Select
        Do Until ActiveCell.Value = ""      'セルが空欄になるまで
    
            Select Case Cells(選択行, 1).Value      '税率設定
                Case Is = 1
                    税率 = 0.1      '通常税率
                    Cells(選択行, 1).Value = "10%"
                Case Is = ""
                    税率 = 0.08     '軽減税率
                    Cells(選択行, 1).Value = "軽"
                Case Is = 0
                    税率 = 0#       '不課税
                    Cells(選択行, 1).Value = "不"
            End Select
        
            
'####　税込額を計算
            Cells(選択行, 3).Formula = Round(Cells(選択行, 2) * (1 + 税率))
            選択行 = 選択行 + 1     '次の行を指定
            ActiveCell.Offset(1).Select     '一つ下の行を参照
        Loop
    
    
'####　番号を振る
        Do Until Cells(選択行2, 2) = ""
            Cells(選択行2, 5) = 行数
            選択行2 = 選択行2 + 1
            行数 = 行数 + 1
        
        Loop
    
    
        終了行 = ActiveCell.Row - 1
    
        
'####　並べ替え（ソート）
        With ActiveSheet.Sort
            .SortFields.Clear
            .SortFields.Add Key:=Cells(終了行, 4), _
                SortOn:=xlSortOnValues, Order:=xlAscending      'D列を基準にして昇順ソート
            .SetRange Cells(終了行, 1).CurrentRegion        '全範囲を指定
            .Header = xlNo      '先頭行を含まない
            .Apply      '実行
        End With
    
        開始行 = 終了行 - Cells(終了行, 1).CurrentRegion.Rows.Count + 1
    
    

'####　D列をH列に複写
        ActiveSheet.Range(Cells(開始行, 4), Cells(終了行, 4)).Copy Range(Cells(開始行, 8), Cells(開始行, 8))
    

'####　重複を削除
        Range(Cells(開始行, 8), Cells(終了行, 8)).RemoveDuplicates Columns:=Array(1), Header:=xlNo
    

'####　新たに開始行2を設定
        開始行2 = 開始行
           
    
'####　費用科目毎に合計（SumIf関数）
        Do Until Cells(開始行2, 8) = ""
            検索条件 = Cells(開始行2, 8).Text   'Textで文字列を取得
            Cells(開始行2, 9) = WorksheetFunction.SumIf(Range(Cells(開始行, 4), Cells(終了行, 4)), 検索条件, Range(Cells(開始行, 3), Cells(終了行, 3)))
            '変数：「検索条件」は既に文字列をとして取得しているので、""で囲んではいけない。
        
            開始行2 = 開始行2 + 1
        Loop
    
    
'####　金額を合計して出力
        金額 = WorksheetFunction.Sum(Range(Cells(開始行, 3), Cells(選択行, 3)))
        Cells(開始行2, 8) = "合計"
        Cells(開始行2, 9).Value = 金額
        Range(Cells(開始行2, 8), Cells(開始行2, 9)).Interior.Color = RGB(255, 255, 0)
    
    
'####　アクティブセルがB列でC列が空欄ではない場合
    Else
        MsgBox "B列を選択していないか既に処理済み"
    
    End If
    
    
    Application.ScreenUpdating = True
    
    
End Sub

コード説明

このマクロを説明します。

変数の宣言

変数	データ型
選択行	Byte	アクティブセルの行数を取得
選択行2	Byte	E列に番号を振るときに使用
行数	Byte	E列に番号を振るときの番号
税率	Single	税率を格納
金額	Integer	C列の税込額の合計
開始行	Byte	C列を合計するときの起点を取得
終了行	Byte	アクティブセルが表の一つ下の行まで移動するので-1として最終行を指定
検索条件	String	SumIf関数の検索条件を格納
開始行2	Byte	科目ごとの集計に使用

まず処理に必要な変数を宣言していますが、初心者ですので行き当たりばったりで必要と感じたものを追加しています。

自分が指定した行から処理を始める仕様にしたかったので、まずは「選択行」という変数を宣言してアクティブセルの行数を取得します。

ちなみに「選択行」のデータ型については255行まで行数を使う可能性が低いためByte（０~255の整数）を指定しています。

Select case文

B列の開始行を指定した場合にだけ処理を始めるためにif文を使い、条件を満たす場合のみA列で設定した区分に応じてSelect case文で「税率」変数に税率を格納するとともにA列で入力した区分を「10％」、「軽」、「不」の三つに表示を変更する仕組みです。

「税率」は少数第二位までの比較的精度の低い数値を格納したいのでここではSingleというデータ型です。

Do until文

税率設定後にDo until文を使って、税抜額を入力した行数分だけB列に税率を乗じて税込額を入力する処理を繰り返しています。

ここで使う税率はA列の区分に応じて

その後、D列の費用区分順にデータを並べ替えます。

Msgbox

最後にC列の税込額を合計してメッセージボックスで表示させます。

合計に関しては端数処理の関係でレシートの額と一致しない場合があります。

VBAを家計簿に活用　レシート集計

目次

表のイメージ

A列に税区分を入力

B列の税抜欄に金額を入力

D列に費用科目を入力

VBAコード