■ 改修のポイント
- オートチャージの(プリペイド)カードは、いわゆる「チャージ」はしないので、「引落」(口座引き落としで商品を購入した場合)と現象は同じ。
- 「引落」は1本なので、何のクレジットカードで購入したかわからない。
- そこで、「複数の引落」を持てるようにしようとするもの。
改修前(マクロ家計簿 version 1.22a)マクロ(Excel-VBA)
■ 集計する()
“引落” をマジェンタ色で表示した。
- Public Sub 集計する()
- Dim mbTitle As String
- Dim wksWorkSheet As Worksheet
- Dim i As Long, lastRow As Long, nowColumn As Long
- Dim strHimoku As String
- Dim clearOnly As Boolean
- mbTitle = "集計する/" & ThisWorkbook.Name
- clearOnly = False
- Worksheets(nowSheetName).Select
- If ActiveSheet.AutoFilterMode Then Selection.AutoFilter
- clearOnly = False
- lngAns = 入力チェック(nowSheetName)
- If lngAns < 0 Then
- clearOnly = True
- ElseIf lngAns > 0 Then
- GoTo Exit_集計する
- End If
- If Not clearOnly Then boolAns = sort日付昇順(nowSheetName)
- nowColumn = get費目Column(nowSheetName) '費目シートの列を求める
- If nowColumn = 0 Then
- MsgBox "費目シートの集計する列が見つかりません。" & vbCrLf & vbCrLf _
- & " ■シート名=" & nowSheetName, vbCritical, mbTitle
- Exit Sub
- End If
- '2014.06.18 上記コメントアウトし、下記1行を追加した。
- boolAns = 費目別に支出を合計する(nowSheetName)
- If Not clearOnly Then boolAns = カードシートを集計する(nowSheetName)
- '費目・シート/入金および総計を集計する。
- lastRow = Worksheets(nowSheetName).Range("D1").End(xlDown).Row
- If lastRow = Rows.Count Then lastRow = 2
- Worksheets("費目").Select
- '総入金計
- Cells(2, nowColumn) = Application.WorksheetFunction _
- .SumIf(Worksheets(nowSheetName).Range("D2:D" & lastRow), "<>チャージ" _
- , Worksheets(nowSheetName).Range("F2:F" & lastRow))
- '費目/入金
- Cells(3, nowColumn) = Application.WorksheetFunction _
- .SumIf(Worksheets(nowSheetName).Range("D2:D" & lastRow), "入金" _
- , Worksheets(nowSheetName).Range("F2:F" & lastRow))
- 'カード/引落
- Cells(4, nowColumn) = Application.WorksheetFunction _
- .SumIfs(Worksheets(nowSheetName).Range("F2:F" & lastRow) _
- , Worksheets(nowSheetName).Range("D2:D" & lastRow), "<>チャージ" _
- , Worksheets(nowSheetName).Range("E2:E" & lastRow), "引落")
- 'その他
- Cells(5, nowColumn) = Application.WorksheetFunction _
- .SumIfs(Worksheets(nowSheetName).Range("F2:F" & lastRow) _
- , Worksheets(nowSheetName).Range("D2:D" & lastRow), "<>チャージ" _
- , Worksheets(nowSheetName).Range("D2:D" & lastRow), "<>入金" _
- , Worksheets(nowSheetName).Range("E2:E" & lastRow), "<>引落")
- '総支出計
- Cells(6, nowColumn) = Application.WorksheetFunction _
- .SumIf(Worksheets(nowSheetName).Range("D2:D" & lastRow) _
- , "<>チャージ", Worksheets(nowSheetName).Range("G2:G" & lastRow))
- '現金
- Cells(7, nowColumn) = Application.WorksheetFunction _
- .SumIfs(Worksheets(nowSheetName).Range("G2:G" & lastRow) _
- , Worksheets(nowSheetName).Range("D2:D" & lastRow), "<>チャージ" _
- , Worksheets(nowSheetName).Range("E2:E" & lastRow), "=")
- '引落
- Cells(8, nowColumn) = Application.WorksheetFunction _
- .SumIfs(Worksheets(nowSheetName).Range("G2:G" & lastRow) _
- , Worksheets(nowSheetName).Range("D2:D" & lastRow), "<>チャージ" _
- , Worksheets(nowSheetName).Range("E2:E" & lastRow), "=引落")
- 'プリペイド
- Cells(9, nowColumn) = Application.WorksheetFunction _
- .SumIfs(Worksheets(nowSheetName).Range("G2:G" & lastRow) _
- , Worksheets(nowSheetName).Range("D2:D" & lastRow), "<>チャージ" _
- , Worksheets(nowSheetName).Range("E2:E" & lastRow), "<>" _
- , Worksheets(nowSheetName).Range("E2:E" & lastRow), "<>引落")
- Call A列で並べる(nowSheetName)
- '日付の最後の次のセルを選択する。
- Worksheets(nowSheetName).Select
- lastRow = Range("B1").End(xlDown).Row
- If lastRow = Rows.Count Then
- Range("B2").Select
- Else
- Cells(lastRow + 1, 2).Select
- End If
- '終了
- Worksheets("カード").Select
- Range("A1").Select
- Exit_集計する:
- ThisWorkbook.Close (False)
- End Sub
■ カードシートを集計する()
改修の必要はない‥‥ と、判断した。
- Function カードシートを集計する(argSheetName As String) As Boolean
- Dim mbTitle As String
- Dim isAutoFil As Boolean
- Dim lastRow As Long, lastCard As Long
- Dim strString As String
- mbTitle = "カードシートを集計する/" & ThisWorkbook.Name
- Sheets(argSheetName).Select
- lastRow = Range("D1").End(xlDown).Row
- Sheets("カード").Select
- strAns = ActiveWorkbook.Name
- strAns = Left(strAns, InStrRev(strAns, ".") - 1)
- Range("B1") = strAns 'ファイル名
- Range("B2") = argSheetName 'シート名
- Range("D1") = Application.WorksheetFunction.Max(Worksheets(argSheetName).Range("B2:B" & lastRow)) '最終日付
- Range("D2") = Now() '集計日
- Range("B5").Select '財布の中/収入
- '2014.09.03 カードが空の入金計に変更した。
- strString = "=SUMIF('" & argSheetName & "'!E2:E" & lastRow & ","""",'" _
- & argSheetName & "'!F2:F" & lastRow & ")"
- ActiveCell.Formula = strString
- Range("C5").Select '財布の中/支出
- strString = "=SUMIF('" & argSheetName & "'!D2:D" & lastRow & ",""チャージ"",'" _
- & argSheetName & "'!G2:G" & lastRow & ")"
- ActiveCell.Formula = strString
- '財布の中/支出(現金)
- Range("D5").Select
- '2014.08.08 入金(F列)を差し引くようにした。
- strString = "=SUMIF('" & argSheetName & "'!E2:E" & lastRow & ","""",'" _
- & argSheetName & "'!G2:G" & lastRow & ")"
- ActiveCell.Formula = strString
- '財布の中/残高
- Range("E5").Select
- strString = "=B5-C5-D5"
- ActiveCell.Formula = strString
- 'カード名の最終行をセットする。
- lastCard = Range("A7").End(xlDown).Row
- If lastCard > 500 + 7 Then
- MsgBox "カード名が無いか、仕様を超えています!" & vbCrLf & vbCrLf _
- & " ■最終行=" & lastCard & vbCrLf & vbCrLf _
- & "カード名「引落」は省略できません。", vbCritical, mbTitle
- Exit Function
- End If
- If lastCard > 8 Then isAutoFil = True Else isAutoFil = False
- '入金の計算式
- Range("B8").Select
- strString = "=SUMIF('" & argSheetName & "'!$E$2:$E$" & lastRow & ",A8,'" _
- & argSheetName & "'!$F$2:$F$" & lastRow & ")"
- ActiveCell.Formula = strString
- 'オートフィルでコピーする。
- If isAutoFil Then
- Range("B8").Select
- Selection.AutoFill Destination:=Range("B8:B" & lastCard)
- End If
- 'チャージの計算式
- Range("C8").Select
- strString = "=SUMIFS('" & argSheetName & "'!$G$2:$G$" & lastRow & ",'" _
- & argSheetName & "'!$D$2:$D$" & lastRow & ",""チャージ"",'" _
- & argSheetName & "'!$E$2:$E$" & lastRow & ",A8)"
- ActiveCell.Formula = strString
- If isAutoFil Then Range("C8").AutoFill Destination:=Range("C8:C" & lastCard)
- '支出
- Range("D8").Select
- strString = "=SUMIF('" & argSheetName & "'!$E$2:$E$" & lastRow & ",A8,'" _
- & argSheetName & "'!$G$2:$G$" & lastRow & ")-C8"
- ActiveCell.Formula = strString
- If isAutoFil Then Range("D8").AutoFill Destination:=Range("D8:D" & lastCard)
- '残高
- Range("E8").Select
- strString = "=B8+C8-D8"
- ActiveCell.Formula = strString
- If isAutoFil Then Range("E8").AutoFill Destination:=Range("E8:E" & lastCard)
- End Function