簿記とエクセル：録太の新生活 11
◎自動生成の試み２
資産型ブックを生成するコードを表示します。
シート１にある開始のコードです。
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 へ戻る