簿記とエクセル:録太の新生活 11


◎自動生成の試み2

  資産型ブックを生成するコードを表示します。

シート1にある開始のコードです。

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal target As Range)
    If Range("c3").Value = "go" Then
        kamoku
    End If
    Range("c3").Value = ""
End Sub


モジュールの共通部分です。

Option Explicit
Dim sname As String
Dim k_code As Integer
Dim renew As Integer
Dim mybname As String
Dim myplname As String
Dim sisan1 As String     ' 資産借方max12'
Dim sisan2 As String
Dim sisan3 As String
Dim sisan4 As String
Dim sisanr1 As String    ' 資産貸方'
  
Dim soneki1 As String    ' 損益借方'
Dim soneki2 As String
Dim soneki3 As String
Dim soneki4 As String
Dim sonekir1 As String   ' 損益貸方'


モジュールのコード:kamoku()です。

Sub kamoku()
    Worksheets(1).Select	' 事前にセルに入れた科目名を取得する方式にしています'
    If Not Cells(11, 1).Value = "" Then sisan1 = Cells(11, 1).Value     ' 資産型 借方:現金'
    If Not Cells(12, 1).Value = "" Then sisan2 = Cells(12, 1).Value     ' 借方:家具類'
    If Not Cells(13, 1).Value = "" Then sisan3 = Cells(13, 1).Value     ' 借方:家電類'
    If Not Cells(14, 1).Value = "" Then sisan4 = Cells(14, 1).Value     ' 借方:衣料類'
    If Not Cells(11, 2).Value = "" Then sisanr1 = Cells(11, 2).Value    ' 貸方:クレジット'
        
    If Not Cells(11, 3).Value = "" Then soneki1 = Cells(11, 3).Value     ' 損益型 借方:食費'
    If Not Cells(12, 3).Value = "" Then soneki2 = Cells(12, 3).Value     ' 借方:日用品'
    If Not Cells(13, 3).Value = "" Then soneki3 = Cells(13, 3).Value     ' 借方:勉学交際'
    If Not Cells(14, 3).Value = "" Then soneki4 = Cells(14, 3).Value     ' 借方:その他'
    If Not Cells(11, 4).Value = "" Then sonekir1 = Cells(11, 4).Value    ' 貸方:収入'
    makeBSbook
End Sub


モジュールのコード:makeBSbook()です。

Sub makeBSbook() ' 新しいブックを生成して、資産系のシートをつくる'
    Dim kth As Integer

    mybname = "myaccbs.xlsx"	' ファイル名を設定します'
    myplname = "myaccpl.xlsx"
    MsgBox "sisan2=" & sisan2	' 一度、操作確認します
    
    Workbooks.Add
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & mybname    ' 名前をつけて保存します'

' マクロを記述したブックにあるcodeシートを、資産型ブックの末尾にcopyし、シート名をcodeにします。'
    ThisWorkbook.Worksheets("code").Copy after:=Workbooks(mybname).Worksheets("sheet3")
    ActiveSheet.Name = "code"
    For kth = 1 To 5
        If kth = 1 Then
            sname = sisanr1 'クレジット'
            k_code = 15
        End If

        If kth = 2 Then
            sname = sisan4  ' 衣料類'
            k_code = 14
        End If
        If kth = 3 Then
            sname = sisan3  ' 家電類'
            k_code = 13
        End If
        If kth = 4 Then
            sname = sisan2  ' 家具類'
            k_code = 12
        End If
        If kth = 5 Then
            sname = sisan1  ' 現金'
            k_code = 11
        End If
       
        Worksheets.Add before:=Worksheets(1)	' それぞれのシートを追加していきます'
        ActiveSheet.Name = sname
        retuMake k_code
        inputStr sname, k_code
    Next kth
    ActiveWorkbook.Save			' 資産型ブックを保存し、閉じます'
    ActiveWorkbook.Close
    renew = 1
    If renew = 1 Then
        makePLstart				' 損益型ブックを生成します'
    End If
    renew = 0
    
    ' sheet3を集計用のシートにします
    ActiveWorkbook.Worksheets("sheet3").Select
    ActiveSheet.Name = "月次合計"
    retuMakePL
End Sub


モジュールのコード:retuMake()です。

Sub retuMake(k_code)      ' 科目シートの列幅などを設定
    'セル幅を設定する   月      日      code    明細    借方    貸方    差引残高    備考    先方    予備'
'                     2.88    2.88    6.5     18      8.75    8.75    9.75        18      8       5'
    Dim i As Integer
    Dim ii As Integer
    Dim tuki As Integer
    Dim r_tuki As Integer
    Dim r_hi As Integer
    Dim r_code As Integer
    Dim r_meisai As Integer
    Dim r_kari As Integer
    Dim r_kashi As Integer
    Dim r_zan As Integer
    Dim r_bikou As Integer
    Dim r_saki As Integer
    Dim r_yobi As Integer

    Worksheets(1).Activate      '先頭のシートのセルの幅を設定します'
    r_tuki = 2.88
    r_hi = 2.88
    r_code = 6.5
    r_meisai = 18
    r_kari = 8.75
    r_kashi = 8.75
    r_zan = 9.75
    r_bikou = 18
    r_saki = 8
    r_yobi = 5

    For i = 1 To 144 Step 12             ' 1か月12の列を使って、12月まで生成します'
        ii = ii + 1                     
        If ii < 10 Then                 ' >'
            tuki = ii   'ii + 3     4月から3月も可能です'
        Else
            tuki = ii   'ii - 9
        End If
        Columns(i).ColumnWidth = r_tuki
        Columns(i + 1).ColumnWidth = r_hi
        Columns(i + 2).ColumnWidth = r_code
        Columns(i + 3).ColumnWidth = r_meisai
        Columns(i + 4).ColumnWidth = r_kari
        Columns(i + 5).ColumnWidth = r_kashi
        Columns(i + 6).ColumnWidth = r_zan
        Columns(i + 7).ColumnWidth = r_bikou
        Columns(i + 8).ColumnWidth = r_saki
        Columns(i + 9).ColumnWidth = r_yobi
        Cells(2, i + 2).Value = k_code
        Cells(1, i + 4).Value = "借方"
        Cells(1, i + 5).Value = "貸方"
        Cells(2, i + 3).Value = tuki & "月度" & sname & "合計"
        Cells(2, i + 4).Value = 0
        Cells(2, i + 5).Value = 0
        Cells(4, i + 3).Value = tuki & "月度"
        Cells(5, i).Value = "月"
        Cells(5, i + 1).Value = "日"
        Cells(5, i + 2).Value = "code"
        Cells(5, i + 3).Value = "明細"
        Cells(5, i + 4).Value = "借方"
        Cells(5, i + 5).Value = "貸方"
        Cells(5, i + 6).Value = "差引残高"
        Cells(5, i + 7).Value = "備考"
        Cells(5, i + 8).Value = "先"
        Cells(5, i + 9).Value = " "	' 予備'
        Cells(6, i).Value = tuki
        Cells(6, i + 1).Value = "1"
        Cells(6, i + 3).Value = "前月より"
        Cells(6, i + 6).Value = 0
        Cells(57, i + 3).Value = tuki & "月度" & sname & "合計"  ' 57行目の合計'
        Cells(57, i + 4).Value = 0
        Cells(57, i + 5).Value = 0
        Range(Cells(2, i + 3), Cells(2, i + 6)).Borders.LineStyle = xlContinuous    ' 科目コード、月度合計'
        Range(Cells(4, i), Cells(5, i + 9)).BorderAround Weight:=xlThin             ' 月度'
        Range(Cells(6, i), Cells(56, i + 9)).BorderAround Weight:=xlThin            ' 項目'
        Range(Cells(57, i), Cells(57, i + 9)).BorderAround Weight:=xlThin           ' 下の合計行'
    Next i
    
    Rows(5).HorizontalAlignment = xlCenter
    Dim kk As Integer
    For kk = 5 To 144 Step 12
        Range(Cells(2, kk), Cells(57, kk + 3)).NumberFormatLocal = "#,##0_ "    ' 3桁区切り'
    Next kk
    Cells(1, 1).Select
End Sub


モジュールのコード:inputStr()です。

Sub inputStr(sname, k_code)     ' 科目シートに項目の文字を入れていく'
    Dim i As Integer
    Dim g As Integer
    Dim tuki As Integer
    Dim code_retu As Integer
    Dim code_do As Integer
    Dim zan_do As Integer
    Dim kari_retu As Integer
    Dim kasi_retu As Integer
    Dim kari_retustr As String
    Dim kasi_retustr As String
     ' セルに数式を記述するとき、オプションの数式/数式の処理/R1C1形式にチェックのこと。'
    Worksheets(1).Activate
    code_retu = -9
    code_do = -8
    kari_retu = -7
    kasi_retu = -6
    zan_do = -5
    
    For i = 1 To 12     ' 月ごとに繰り返す'
        If i < 10 Then  ' >'
            tuki = i
        Else
            tuki = i
        End If
        code_retu = code_retu + 12
        code_do = code_do + 12
        kari_retu = kari_retu + 12
        kasi_retu = kasi_retu + 12
        zan_do = zan_do + 12
        
        If tuki = 1 Then kari_retustr = "e7:e56"
        If tuki = 1 Then kasi_retustr = "f7:f56"
        If tuki = 2 Then kari_retustr = "q7:q56"
        If tuki = 2 Then kasi_retustr = "r7:r56"
        If tuki = 3 Then kasi_retustr = "ad7:ad56"
        If tuki = 3 Then kari_retustr = "ac7:ac56"
        If tuki = 4 Then kari_retustr = "ao7:ao56"
        If tuki = 4 Then kasi_retustr = "ap7:ap56"
        If tuki = 5 Then kari_retustr = "ba7:ba56"
        If tuki = 5 Then kasi_retustr = "bb7:bb56"
        If tuki = 6 Then kari_retustr = "bm7:bm56"
        If tuki = 6 Then kasi_retustr = "bn7:bn56"
        If tuki = 7 Then kari_retustr = "by7:by56"
        If tuki = 7 Then kasi_retustr = "bz7:bz56"
        If tuki = 8 Then kari_retustr = "ck7:ck56"
        If tuki = 8 Then kasi_retustr = "cl7:cl56"
        If tuki = 9 Then kari_retustr = "cw7:cw56"
        If tuki = 9 Then kasi_retustr = "cx7:cx56"
        If tuki = 10 Then kari_retustr = "di7:di56"
        If tuki = 10 Then kasi_retustr = "dj7:dj56"
        If tuki = 11 Then kari_retustr = "du7:du56"
        If tuki = 11 Then kasi_retustr = "dv7:dv56"
        If tuki = 12 Then kari_retustr = "eg7:eg56"
        If tuki = 12 Then kasi_retustr = "eh7:eh56"
        Cells(2, kari_retu).FormulaR1C1 = "=R57C" & kari_retu ' 上部借方'
        Cells(2, kasi_retu).FormulaR1C1 = "=R57C" & kasi_retu  ' 上部貸方'
        Cells(57, kari_retu).Value = "=sum(" & kari_retustr & ")"  ' 上部借方'
        Cells(57, kasi_retu).Value = "=sum(" & kasi_retustr & ")" ' 上部貸方'

        ' 当月の部分'
        For g = 7 To 56     ' 当該列の7行目から56行目のセルに記述する'
            If k_code > 0 And k_code < 20 Then	'>'
				Cells(g, code_do).FormulaR1C1 = "=IF(R" & [g] & "C" & [code_retu] & "="""","""", _
					VLOOKUP(R" & [g] & "c" & [code_retu] & ",code!r2c1: r100c2,2,FALSE))"
				If k_code = 15 Then
					Cells(g, zan_do).FormulaR1C1 = "=IF(R" & [g] & "C" & [code_retu] & "="""","""", _
					R[-1]C - RC[-2] + RC[-1])"
                Else
                    Cells(g, zan_do).FormulaR1C1 = "=IF(R" & [g] & "C" & [code_retu] & "="""","""", _
					R[-1]C + RC[-2] - RC[-1])"
                End If
            ElseIf k_code = 20 Then
            
            ElseIf k_code > 20 And k_code < 26 Then		'>'
                If k_code = 21 Then
                    Cells(g, code_do).FormulaR1C1 = "=IF(R" & [g] & "C" & [code_retu] & "="""","""", _
						VLOOKUP(R" & [g] & "c" & [code_retu] & ", _
						 [" & mybname & "]code!r2c1: r100c2 , 2, False))"
                    Cells(g, zan_do).FormulaR1C1 = "=IF(R" & [g] & "C" & [code_retu] & "="""","""", _
						R[-1]C - RC[-2] + RC[-1])"
                Else
                    Cells(g, code_do).FormulaR1C1 = "=IF(R" & [g] & "C" & [code_retu] & "="""","""", _
						VLOOKUP(R" & [g] & "c" & [code_retu] & ", _
						 [" & mybname & "]code!r2c1: r100c2 , 2, False))"
                    Cells(g, zan_do).FormulaR1C1 = "=IF(R" & [g] & "C" & [code_retu] & "="""","""", _
						R[-1]C + RC[-2] - RC[-1])"
                End If
            End If
        Next g
    Next i
    Range("6:6").Select
    ActiveWindow.FreezePanes = True  ' 枠の固定'
    Dim kk As Integer
    For kk = 5 To 144 Step 12
        Range(Cells(2, kk), Cells(57, kk + 3)).NumberFormatLocal = "#,##0_ "    ' 3桁区切り'
    Next kk
    Range("b7").Select
End Sub


この企画の目標は、「家計簿をエクセルで実現しながら簿記を知ることができる」です。



録太の新生活 12、次へ進む
簿記とエクセルのトップページへ戻る

Home へ戻る

ピヨ
中小企業診断士受験のサイト
…… 運営者:TEAM(This is every accessible meeting.) Copyright 2022 ……