ExcelVBAで家計簿アプリを作ろう　その9-5

家計簿アプリを、より使いやすく自分仕様に改造していきましょう！

以前の投稿で、家計簿アプリとして最低限の機能を持たせることができました。
（その６までをご確認いただいていない方は、まずは下記まとめをご確認ください。）

ただ、これは本当に最低限の機能しかなく、勘定科目も『固定費』と『変動費』しかないので、
各家庭に合った勘定科目を自由に追加できるように、
このマクロのデコレーションをしていく必要があります。

前回からダウンロードしてきた明細書を基に、おおよそでリストに記入できるようにしていくマクロの作成に取り掛かっています。

前回までで、貼り付けたデータについて、所定の月のデータにフィルターかけて必要な月のデータだけコピーするところまでできました。
今回はその続き、コピーしたものを貼り付けるため、シートの修正や、シートを変数に定義して省略して書く方法について説明していきます。

シートなどのオブジェクトを変数に定義できるようになると、マクロに書く内容がさらに洗練されたものになっていき、かつ見やすく、後で修正がやりやすいものになっていきます。
頑張って慣れていきましょう！

【本記事の目標】

オブジェクトの変数定義の方法を知ろう

最終仕上げをしていこう

簡単なイメージは下記記事に記載していますので、イメージづくりや今回以降の流れの参考に。
また、前回までの記事については下記をご確認ください。

「入力」シートの修正
シートを変数に入れていく
1. 変数の種類と定義の仕方の違い
2. 今回のマクロでシートを定義していく
前回の続き、フィルターした内容をコピーしていく
ダウンロードした明細書からの自動入力マクロが完成！

「入力」シートの修正

前回の続きですと、フィルターした項目のコピーからですが、コピーした内容を貼り付ける場所が完成していないので、先にそちらの修正をしていきましょう。

現状だと入力シートに入力する項目は、下記の状態になっています。

1件1件入力していく場合は、あまり入力する項目が多すぎると手間がかかってしまうので、「金額」と「勘定科目」に絞っていましたが、
明細書をダウンロードして読み込む場合、その明細書に記載の内容はマクロでコピーするだけで完了するので、せっかくなので貼り付けられる場所を作っておきましょう。

具体的には
　・日付
　・内容（支払先等）
の２つです。

また、明細書に記載の「内容」（支払先）だけだと細かい内容が良く分からない場合が多いと思います。
基本的にはざっくりとした勘定科目を決められたらそれでOKだと思いますが、金額が極端に大きい場合は詳細な説明を書けるようにしておいた方が良いですよね。
（ご祝儀とか、お祝い金とか、自動車購入費とか、ごくまれに発生する大きな金額関係）
こういったものをかけるように「備考欄」も追加しておいた方が良いかと思います。

そうなってくると、現状空欄のG列・H列だけだと足りなくなってしまいます。
そこで、現状だと「収入金額」「支出金額」で分けていましたが、特に分ける必要もないので、「金額」という項目にして１つにまとめてしまいましょう。
ただその場合、K列に記載してある計算式がほぼ全て修正が必要になってきますので、K列の計算式を修正しておきましょう。

これらの内容を反映させた後の入力シートは下記のようになりました。

また、K列の関数は下記のようになっています。

これで明細書に記載の内容を貼り付ける場所を準備することができました。
それではいよいよフィルターをかけたデータを貼り付ける作業をしていきましょう。

シートを変数に入れていく

前回記載した通り、フィルターをかけた領域をコピーしていこうと思うと、複数のシートにまたがってコピー＆ペーストをしていかないといけないので、どうしてもマクロが煩雑になってしまいます。

そこで、シートそのものを変数に入れてしまって、より分かりやすい（後々修正がしやすい）マクロにしていきましょう。

変数の種類と定義の仕方の違い

変数の定義に関しては最初の最初でも説明していますが、基本的には、

　Dim　変数名　As　データ形式

という書き方で定義をすることができます。

変数を定義した直後は、その変数の中身は空っぽの状態ですので、
ここに色々なデータを入れていきながらマクロを動かしていくことになります。

ただ、ここで指定する「データ形式」は、
　String（文字列）
　Integer（整数）
　Double（倍精度浮動小数点）
　Boolean（TrueとFalse）
といった、所謂データを入れるための変数の場合であれば、上記の定義の後に、

　変数名　=　データ

という式を書いてあげれば、
定義した変数の中に指定したデータ形式のデータが代入されていきます。

しかし、この「データ形式」は上記のような所謂データだけでなく、
　Workbook（Excelブック）
　Worksheet（Excelワークシート）
　Shape（図形）
　GraphChart（グラフ）
　ListObject（テーブル）
といった、色々な情報が詰まった『オブジェクト』でも定義することができます。
（過去の投稿で説明したことのある、ファイル操作の「FileSystemObject」も『オブジェクト』です）

こういった『オブジェクト』の変数を定義した場合、
最初はもちろん空っぽなので、何かを入れてあげる必要があるのですが、
文字列等のデータの場合と違って単純なデータではないので、
　変数名　＝　オブジェクト
だけでは代入することができません。

このような『オブジェクト』の場合、データを代入するというより、
指定のオブジェクトをセットする、といった作業が必要になります。

オブジェクトをセットするには下記のように記載する必要があります。

　Set　変数名　＝　セットするオブジェクト

このように最初にオブジェクトをセットしてあげていれば、
以降は変数名だけでそのオブジェクトを操作することができるようになります。

たとえば今回のように、このExcelファイルにある”入力”というシートを、
「sh1」という変数に定義＆セットしようとすると、
　　Dim sh1 as Worksheet
　　Set sh1 = ThisWorkbook.Worksheets(“入力”)
といった書き方でセットが可能になります。

これ以降は「ThisWorkbook.Sheets(“入力”)」と記載しないといけなかった部分も、「sh1」と記載するだけで使うことができるようになるのです。

今回のマクロでシートを定義していく

上記を踏まえて、今回定義しておきたいものは、
　「入力」のシート
　「カード明細用」のシート
　「銀行明細用」のシート
の３つかと思いますので、これらのシートを使うプロシージャの最初に、
下記のように定義をしておけば、シートの操作やシートの中のRange、Cellといった操作がやりやすくなります。

　Dim sh1 as Worksheet
　Dim sh2 as Worksheet
　Dim sh3 as Worksheet
　Set sh1 = ThisWorkbook.Worksheets(“入力”)
　Set sh2 = ThisWorkbook.Worksheets(“カード明細用”)
　Set sh3 = ThisWorkbook.Worksheets(“銀行明細用”)

具体的には、今作ろうとしているカード明細のファイルを貼り付けるマクロだと、
下記のように書き換えることができます。

Option Explicit

Sub CardMeisaiCopy()
'カード明細サンプルを貼り付けるマクロ

Dim FileName1 As String

Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Set sh1 = ThisWorkbook.Worksheets("入力")
Set sh2 = ThisWorkbook.Worksheets("カード明細用")
Set sh3 = ThisWorkbook.Worksheets("銀行明細用")

'ファイルを開く
FileName1 = Application.GetOpenFilename
Workbooks.Open Filename:=FileName1

'ファイルのデータを所定のシートに貼り付ける
ActiveWorkbook.Sheets(1).Range("A:C").Copy
sh2.Range("A:C").PasteSpecial
Application.CutCopyMode = False

'ファイルを閉じる
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True

'===========オートフィルター部分==============

Dim SearchYear1 As Integer
Dim SearchMonth1 As Integer
Dim EndRow1 As Integer
Dim FilterString1 As String     'フィルター条件の文字列

With sh1
    SearchYear1 = .Range("M4").Value
    SearchMonth1 = .Range("O4").Value
    FilterString1 = SearchYear1 & "." & SearchMonth1 & "*"
End With
  
With sh2
    EndRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range(.Cells(1, 1), .Cells(EndRow1, 6)).AutoFilter Field:=1, Criteria1:=FilterString1, Operator:=xlFilterValues
    
    '以降でフィルターをかけた領域をコピーし、「入力」シートに貼り付けていく

今回は分かりやすくするため、一旦『CardMeisaiCopy』のプロシージャの中のプライベート変数として定義（Dimで定義）していますが、このようなシートの定義は他のプロシージャの中でも使う可能性が大いにあるので、本当はパブリック変数として定義する方が好ましいです。
ただし、変数自体の定義はモジュール内のプロシージャの外でも定義が可能ですが、変数の中にオブジェクトをセットするためには基本的にプロシージャ内でしかできません。

そこで、多数のパブリック変数にオブジェクトをセットしていく際には、オブジェクトをセットするだけのプロシージャを作っておき、全てのプロシージャの最初の部分でそのプロシージャを呼び出すようにしておくと、後々の修正がやりやすくなります。

このあたりのテクニックに関しては、このマクロのが完成した最後のブラッシュアップで説明していこうと思います。

前回の続き、フィルターした内容をコピーしていく

フィルターした内容をコピー

それでは、貼り付け先のシートも修正が完了しましたし、各シートも変数にセットしましたので、いよいよ前回の続きの「フィルターをかけた内容のコピー」をやっていきましょう。

とはいえ、実はもうほとんど出来上がっていて、
フィルターをかけるためにデータの最初の行と最後の行は分かっていますし、
『カード明細用』のシートの何列目を『入力』のシートの何列目に貼り付けたいかもわかっていますので、
　（『カード明細用』のシートの１列目を『入力』のシートの７列目に：日付）
　（『カード明細用』のシートの２列目を『入力』のシートの６列目に：内容）
　（『カード明細用』のシートの３列目を『入力』のシートの５列目に：金額）
　（『カード明細用』のシートの６列目を『入力』のシートの４列目に：勘定科目）
この部分を　Copy＆Paste　をしていくだけで完成です。

With sh2
    'オートフィルターを実施している部分
    EndRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range(.Cells(1, 1), .Cells(EndRow1, 6)).AutoFilter Field:=1, Criteria1:=FilterString1, Operator:=xlFilterValues
    
    
    'フィルターをかけた領域をコピーし、「入力」シートに貼り付けていく
    .Range(.Cells(2, 1), .Cells(EndRow1, 1)).Copy
    sh1.Range(sh1.Cells(8, 7), sh1.Cells(8 + EndRow1 - 1, 7)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    .Range(.Cells(2, 2), .Cells(EndRow1, 2)).Copy
    sh1.Range(sh1.Cells(8, 6), sh1.Cells(8 + EndRow1 - 1, 6)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    .Range(.Cells(2, 3), .Cells(EndRow1, 3)).Copy
    sh1.Range(sh1.Cells(8, 5), sh1.Cells(8 + EndRow1 - 1, 5)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    .Range(.Cells(2, 6), .Cells(EndRow1, 6)).Copy
    sh1.Range(sh1.Cells(8, 4), sh1.Cells(8 + EndRow1 - 1, 4)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    
    .Range(.Cells(1, 1), .Cells(EndRow1, 6)).AutoFilter 'オートフィルターの解除
    
End With

入力シートに勘定科目を再入力

上記のマクロを『CardMeisaiCopy』のプロシージャに記載すれば、詳細な勘定科目や金額・内容などを『入力』シートに自動的に記載することができます。

ただ、以前に作ってある勘定科目を入力するマクロを使っていないので、
より広い【収入か支出か】、【変動費か固定費か】といった選択肢の部分は自動的には記載されません。
なので、自動入力された詳細な勘定科目を確認して、【収入か支出か】、【変動費か固定費か】についても自動入力できるようにしておきましょう。

手順の流れとしては下記図のイメージです。

まずは貼り付けた詳細科目を確認していきましょう。

貼り付ける際に、貼り付けた領域の大きさは分かっているので、そのまま活用します。
上から順番に確認していきますので、For文を使って
「InKamoku」という変数に確認した詳細科目を入れていきます。

Dim i As Integer
Dim InKamoku As String
For i = 8 To (8 + EndRow1 – 1)
InKamoku = sh1.Cells(i, 4).Value
Next i

この「InKamoku」の値が、右側のリストのどこにあるかを確認していきますので、
重ねてFor文を使って確認し、「CheckKamoku」という変数に今確認している詳細科目を入れていきます。

Dim i As Integer
Dim j As Integer
Dim InKamoku As String
Dim CheckKamoku As String
For i = 8 To (8 + EndRow1 – 1)
InKamoku = sh1.Cells(i, 4).Value
For j = 10 To 18
CheckKamoku = sh1.Cells(j, 10).Value
Next j
Next i

あとは、「InKamoku」の値と「CheckKamoku」の値が一致したとき、「CheckKamoku」の左隣のセルの値を、「InKamoku」の左隣に入力します。
また「CheckKamoku」の左隣のセルの値が空欄だった時は、「InKamoku」の２個左隣に『収入』と記入します。
さらに、そもそも「InKamoku」の値が空欄だった場合は、そもそもチェックせずに次の値を確認します。

これらの分岐は、全て下記のようにIF文を組み合わせていくことで実現できます。

Dim i As Integer
Dim j As Integer
Dim InKamoku As String
Dim CheckKamoku As String
For i = 8 To (8 + EndRow1 - 1)
    InKamoku = sh1.Cells(i, 4).Value
    If InKamoku <> "" Then
    For j = 10 To 18
        CheckKamoku = sh1.Cells(j, 10).Value
        If InKamoku = CheckKamoku Then
            If sh1.Cells(j, 9).Value <> "" Then
            sh1.Cells(i, 3).Value = sh1.Cells(j, 9).Value
            sh1.Cells(i, 2).Value = "支出"
            ElseIf sh1.Cells(j, 9).Value = "" Then
                sh1.Cells(i, 2).Value = "収入"
            End If
        End If
    Next j
    End If
Next i

空欄の勘定科目に勘定科目を入力

これでほとんどの内容を、ダウンロードした明細を読み込むことで自動入力できるようになりました。
ただ、どうしても事前準備リストだけで網羅できない項目は必ず出てきて、その部分の勘定科目は空欄のままになってしまっています。

そこで、以前に作った勘定科目を選択するボタンを使って、
金額入力の欄が空欄もしくは「０」が記載されている場合、現在選択中のセルに勘定科目を入力する、というマクロを組んでおきましょう。

流れのイメージは下記の通りです。

これは勘定科目を入力するマクロの部分を修正する必要があるので、『KamokuInput_1』のプロシージャを修正していきます。

以前に作ったマクロの中に　If文　を使って、金額入力の欄が空欄かどうか、という分岐をさせます。
空欄でない場合は以前に作ったマクロをそのまま使い、空欄だった場合は選択したセルの部分に勘定科目を入力させます。
またこの時に、入力したい勘定科目や【収入/支出】【固定費/変動費】については、金額入力が空欄であろうとなかろうと必要な情報になってきますので、このあたりのデータの取得はIf文よりも外で事前に取得しておく方が良いです。

また、金額入力が空欄で選択したセルに勘定科目を入力していく際、たまたま変なセルを選択してる状態で勘定科目入力のボタンを誤操作してしまった場合、そのセルには勘定科目が入力されないように、If文を使って分岐させておきましょう。
指定された場所（B～D列）を選択した状態でなければ勘定科目が入力されないようになります。

これらを踏まえたうえで、『KamokuInput_1』のプロシージャを修正した結果が下記のようになります。

Option Explicit

Sub KamokuInput_1(PositionNum1 As Integer)
'リストに追加をクリック

Dim Kingaku1 As Double
Dim Syushi1 As String
Dim Kamoku1 As String
Dim Kamoku2 As String
Syushi1 = ""
Kamoku1 = ""
Kamoku2 = ""

'シート上から勘定科目を読み取る
With ThisWorkbook.ActiveSheet
    Kamoku1 = .Range("I9").Offset(PositionNum1, 0).Value
    Kamoku2 = .Range("J9").Offset(PositionNum1, 0).Value
    If Kamoku1 = "" Then
        Syushi1 = "収入"
    Else
        Syushi1 = "支出"
    End If
End With

Kingaku1 = ThisWorkbook.ActiveSheet.Range("C3").Value

'勘定科目を1つずつ入力する場合
If Kingaku1 <> 0 Then

Dim EndRow1 As Integer
With ThisWorkbook.ActiveSheet

EndRow1 = .Cells(.Rows.Count, 2).End(xlUp).Row
EndRow1 = EndRow1 + 1

.Cells(EndRow1, 2).Value = Syushi1
.Cells(EndRow1, 3).Value = Kamoku1
.Cells(EndRow1, 4).Value = Kamoku2
.Cells(EndRow1, 5).Value = Kingaku1
End With

'自動入力できなかった欄に勘定科目を入力する場合
Else

Dim ActCol1 As Integer
Dim ActRow1 As Integer

ActCol1 = ActiveCell.Column
ActRow1 = ActiveCell.Row

If ActCol1 >= 2 And ActCol1 <= 4 Then
With ThisWorkbook.ActiveSheet
    .Cells(ActRow1, 2).Value = Syushi1
    .Cells(ActRow1, 3).Value = Kamoku1
    .Cells(ActRow1, 4).Value = Kamoku2
End With
End If
End If

End Sub

ダウンロードした明細書からの自動入力マクロが完成！

以上でダウンロードした明細書からの自動入力マクロや、それに付随するマクロの修正は完了です。
今回作成した『CardMeisaiCopy』のプロシージャや『BankMeisaiCopy』のプロシージャを起動できるように、下記のように『入力』シートにボタンを作ってマクロを登録しておきましょう。

最終的に完成したマクロおよび変更したモジュール（プロシージャ）を下記に記載しておきます。

【CardMeisaiCopy】プロシージャ　（FileDataCopy　モジュール）

Sub CardMeisaiCopy()
'カード明細サンプルを貼り付けるマクロ

Dim FileName1 As String

Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Set sh1 = ThisWorkbook.Worksheets("入力")
Set sh2 = ThisWorkbook.Worksheets("カード明細用")
Set sh3 = ThisWorkbook.Worksheets("銀行明細用")

'ファイルを開く
FileName1 = Application.GetOpenFilename
Workbooks.Open Filename:=FileName1

'ファイルのデータを所定のシートに貼り付ける
ActiveWorkbook.Sheets(1).Range("A:C").Copy
sh2.Range("A:C").PasteSpecial
Application.CutCopyMode = False

'ファイルを閉じる
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True

'===========オートフィルター部分==============

Dim SearchYear1 As Integer
Dim SearchMonth1 As Integer
Dim EndRow1 As Integer
Dim FilterString1 As String     'フィルター条件の文字列

  
With sh1
    SearchYear1 = .Range("M4").Value
    SearchMonth1 = .Range("O4").Value
    FilterString1 = SearchYear1 & "." & SearchMonth1 & "*"
End With
  
With sh2
    'オートフィルターを実施している部分
    EndRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range(.Cells(1, 1), .Cells(EndRow1, 6)).AutoFilter Field:=1, Criteria1:=FilterString1, Operator:=xlFilterValues
    
    
    'フィルターをかけた領域をコピーし、「入力」シートに貼り付けていく
    .Range(.Cells(2, 1), .Cells(EndRow1, 1)).Copy
    sh1.Range(sh1.Cells(8, 7), sh1.Cells(8 + EndRow1 - 1, 7)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    .Range(.Cells(2, 2), .Cells(EndRow1, 2)).Copy
    sh1.Range(sh1.Cells(8, 6), sh1.Cells(8 + EndRow1 - 1, 6)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    .Range(.Cells(2, 3), .Cells(EndRow1, 3)).Copy
    sh1.Range(sh1.Cells(8, 5), sh1.Cells(8 + EndRow1 - 1, 5)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    .Range(.Cells(2, 6), .Cells(EndRow1, 6)).Copy
    sh1.Range(sh1.Cells(8, 4), sh1.Cells(8 + EndRow1 - 1, 4)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    
    .Range(.Cells(1, 1), .Cells(EndRow1, 6)).AutoFilter 'オートフィルターの解除
    
    
Dim i As Integer
Dim j As Integer
Dim InKamoku As String
Dim CheckKamoku As String
For i = 8 To (8 + EndRow1 - 1)
    InKamoku = sh1.Cells(i, 4).Value
    If InKamoku <> "" Then
    For j = 10 To 18
        CheckKamoku = sh1.Cells(j, 10).Value
        If InKamoku = CheckKamoku Then
            If sh1.Cells(j, 9).Value <> "" Then
            sh1.Cells(i, 3).Value = sh1.Cells(j, 9).Value
            sh1.Cells(i, 2).Value = "支出"
            ElseIf sh1.Cells(j, 9).Value = "" Then
                sh1.Cells(i, 2).Value = "収入"
            End If
        End If
    Next j
    End If
Next i
    
End With

End Sub

【BankMeisaiCopy】プロシージャ　（FileDataCopy　モジュール）


Sub BankMeisaiCopy()
'銀行明細サンプルを貼り付けるマクロ

Dim FileName1 As String

Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim sh3 As Worksheet
Set sh1 = ThisWorkbook.Worksheets("入力")
Set sh2 = ThisWorkbook.Worksheets("カード明細用")
Set sh3 = ThisWorkbook.Worksheets("銀行明細用")

'ファイルを開く
FileName1 = Application.GetOpenFilename
Workbooks.Open Filename:=FileName1

'ファイルのデータを所定のシートに貼り付ける
ActiveWorkbook.Sheets(1).Range("A:D").Copy
sh3.Range("A:C").PasteSpecial
Application.CutCopyMode = False

'ファイルを閉じる
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True

'===========オートフィルター部分==============

Dim SearchYear1 As Integer
Dim SearchMonth1 As Integer
Dim EndRow1 As Integer
Dim FilterString1 As String     'フィルター条件の文字列

With sh1
    SearchYear1 = .Range("M4").Value
    SearchMonth1 = .Range("O4").Value
    FilterString1 = SearchYear1 & "." & SearchMonth1 & "*"
End With
  
With sh3
    'オートフィルターを実施している部分
    EndRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range(.Cells(1, 1), .Cells(EndRow1, 6)).AutoFilter Field:=1, Criteria1:=FilterString1, Operator:=xlFilterValues
    
    
    'フィルターをかけた領域をコピーし、「入力」シートに貼り付けていく
    .Range(.Cells(2, 1), .Cells(EndRow1, 1)).Copy
    sh1.Range(sh1.Cells(8, 7), sh1.Cells(8 + EndRow1 - 1, 7)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    .Range(.Cells(2, 2), .Cells(EndRow1, 2)).Copy
    sh1.Range(sh1.Cells(8, 6), sh1.Cells(8 + EndRow1 - 1, 6)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    .Range(.Cells(2, 7), .Cells(EndRow1, 7)).Copy
    sh1.Range(sh1.Cells(8, 5), sh1.Cells(8 + EndRow1 - 1, 5)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    .Range(.Cells(2, 6), .Cells(EndRow1, 6)).Copy
    sh1.Range(sh1.Cells(8, 4), sh1.Cells(8 + EndRow1 - 1, 4)).PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    
    .Range(.Cells(1, 1), .Cells(EndRow1, 6)).AutoFilter 'オートフィルターの解除
    
Dim i As Integer
Dim j As Integer
Dim InKamoku As String
Dim CheckKamoku As String
For i = 8 To (8 + EndRow1 - 1)
    InKamoku = sh1.Cells(i, 4).Value
    If InKamoku <> "" Then
    For j = 10 To 18
        CheckKamoku = sh1.Cells(j, 10).Value
        If InKamoku = CheckKamoku Then
            If sh1.Cells(j, 9).Value <> "" Then
            sh1.Cells(i, 3).Value = sh1.Cells(j, 9).Value
            sh1.Cells(i, 2).Value = "支出"
            ElseIf sh1.Cells(j, 9).Value = "" Then
                sh1.Cells(i, 2).Value = "収入"
            End If
        End If
    Next j
    End If
Next i
    
End With

End Sub

【KamokuInput_1】プロシージャ　（KamokuInput　モジュール）

Option Explicit

Sub KamokuInput_1(PositionNum1 As Integer)
'リストに追加をクリック

Dim Kingaku1 As Double
Dim Syushi1 As String
Dim Kamoku1 As String
Dim Kamoku2 As String
Syushi1 = ""
Kamoku1 = ""
Kamoku2 = ""

'シート上から勘定科目を読み取る
With ThisWorkbook.ActiveSheet
    Kamoku1 = .Range("I9").Offset(PositionNum1, 0).Value
    Kamoku2 = .Range("J9").Offset(PositionNum1, 0).Value
    If Kamoku1 = "" Then
        Syushi1 = "収入"
    Else
        Syushi1 = "支出"
    End If
End With

Kingaku1 = ThisWorkbook.ActiveSheet.Range("C3").Value

'勘定科目を1つずつ入力する場合
If Kingaku1 <> 0 Then

Dim EndRow1 As Integer
With ThisWorkbook.ActiveSheet

EndRow1 = .Cells(.Rows.Count, 2).End(xlUp).Row
EndRow1 = EndRow1 + 1

.Cells(EndRow1, 2).Value = Syushi1
.Cells(EndRow1, 3).Value = Kamoku1
.Cells(EndRow1, 4).Value = Kamoku2
.Cells(EndRow1, 5).Value = Kingaku1
End With

'自動入力できなかった欄に勘定科目を入力する場合
Else

Dim ActCol1 As Integer
Dim ActRow1 As Integer

ActCol1 = ActiveCell.Column
ActRow1 = ActiveCell.Row

If ActCol1 >= 2 And ActCol1 <= 4 Then
With ThisWorkbook.ActiveSheet
    .Cells(ActRow1, 2).Value = Syushi1
    .Cells(ActRow1, 3).Value = Kamoku1
    .Cells(ActRow1, 4).Value = Kamoku2
End With
End If
End If

End Sub

次の記事へ