【就労支援×Excel】家計簿入力訓練を自動化するVBAお題生成システムの作り方

2026年7月5日2026年9月5日

【就労支援×Excel】家計簿入力訓練を自動化.VBAお題生成システムの作り方のアイキャッチ画像

Excel と VBA を使った「家計簿入力トレーニング」は、就労支援・自立訓練の現場で非常に効果の高い訓練方法です。

前回の記事では、Excel 上で動作するストップウォッチ（スタート／ストップ／リセット）の作り方を紹介しました。

Excel仕事術ブログ

【VBA】ストップウォッチの作り方とコードを初心者向けに解説！ | Excel仕事術ブログ Excelを使用していると、データ入力の訓練や課題の練習など、ストップウォッチ機能があったら便利・・・ということも多いでしょう。実は私は普段パソコン講座なども行って…

今回はその応用として、支援現場で実際に使える「家計簿入力訓練ツール」を作っていきます。

ツールの特徴

12か月分のお題シートを自動生成
利用者が入力した家計簿を自動採点
間違い箇所は赤字太字で強調
採点結果を一覧表に自動記録
全員分を一括採点する機能つき

上記尾用に実務レベルの機能を備えています。

Excel と VBA の組み合わせで、ここまで「訓練ツール」として完成度の高い仕組みを作れることを、ぜひこの記事を通して体験してみてください。

また、もしマクロやVBAなどの基本部分から学びたい方は【初心者向け】Excelのマクロ・VBAの基本まとめの記事から見てみましょう。

家計簿入力訓練ツールとは？

Excel を使った家計簿入力は、就労支援・自立訓練の現場で非常に効果の高いトレーニングです。

私は現役の就労支援員として、Excel講座や就職活動の前段階で訓練している内容の応用版です。

特に「正確性」「集中力」「時間管理」の3つを同時に鍛えられるため、事務職・軽作業・PC業務など幅広い職種に応用できます。

しかし、家計簿入力の訓練を毎回手作業で作成するのは大変です。

そこで今回の記事では、Excel と VBA を使って、家計簿入力のお題を自動生成し、採点まで自動化できるシステムの作り方を紹介します。

支援現場でのニーズと課題

支援現場では「入力の正確性を鍛えたい」「毎月の訓練内容を自動化したい」という声が多くあります。
しかし、手作業で家計簿データを作ると時間がかかり、支援員の負担も大きくなります。

今回のシステムは、支援員の負担を減らしつつ、利用者の学習効果を最大化することを目的にしています。

Excel × VBA で訓練を自動化するメリット

今回のツールを利用するメリットは以下となります。

12か月分のお題を一瞬で作成できる
利用者の入力結果を自動採点できる
間違い箇所を赤字太字で強調できる
採点結果を一覧表に自動記録できる
ストップウォッチと組み合わせて時間管理訓練も可能

今回作るシステムの全体像

今回作る家計簿入力訓練システムは、以下の3つのシートで構成されています。

お題生成シート（1月～12月）

支援員がボタンを押すだけで、12か月分のお題シートが自動生成されます。
収入・支出の金額はランダムで作成され、利用者ごとに異なる家計簿を作ることができます。

利用者用家計簿シート（黒子家の家計簿など）

利用者が実際に入力する家計簿シートです。
ストップウォッチ機能（前回の記事で紹介）と組み合わせることで、時間管理の訓練にもなります。

採点シート（正解数・ミス数・正解率）

採点結果を自動で記録するシートです。
正解数・ミス数・正解率は自動計算され、グラフで視覚的に確認できます。

ストップウォッチとの連携（前回記事）

前回の記事で紹介した「スタート／ストップ／リセット」のストップウォッチ機能を使うことで、入力時間の計測も可能になります。

お題生成シートの作り方

それでは、実際にお題生成シートの作り方に入ります。

家計簿シートのテンプレート作成

Excelを起動したら、「その他のテンプレート」をクリックします。

次に、「月間家計簿」のテンプレートをクリックします。私の場合は最近使ったので一番最初にあるのですが、並び順は人によって違います。

「作成」をクリックします。

私は文字の色が見えにくいと感じたので、黒色に変更しました。また、年数は2026など好きな年数に変えてもいいと思います。

ストップウォッチ導入

前回の記事【VBA】ストップウォッチの作り方とコードを初心者向けに解説！で紹介したように、ストップウォッチも入れてみましょう。

E2セルに開始、F2セルに終了、F2セルに時間と入力します。

マクロのボタンはVBAのボタン挿入でもいいのですが、私は好みの色に自由にカスタマイズするために図形を配置してマクロを設定することが多いです。

マクロのコードはまだ入力していないので、まずは以下の図のように下準備をします。

次にAlt+11でコード入力画面になりますので、「挿入」タブで標準モジュールを挿入します。

標準モジュールの中に以下のコードを入力します。

Public StartTime As Date
Public Running As Boolean

Sub StartTimer()
    ' リセットして開始
    ResetTimer
    
    ' スタート時刻を記録
    StartTime = Now
    Range("E3").Value = StartTime
    Range("E3").NumberFormat = "hh:mm:ss"
    
    ' 動作中フラグを立てる
    Running = True
    
    ' 経過時間のリアルタイム更新開始
    UpdateTimer
End Sub

Sub UpdateTimer()
    ' 停止中なら更新しない
    If Running = False Then Exit Sub
    
    ' 経過時間を表示
    Range("G3").Value = Now - StartTime
    Range("G3").NumberFormat = "hh:mm:ss"
    
    ' 次の更新を予約（1秒ごと）
    Application.OnTime Now + TimeValue("00:00:01"), "UpdateTimer"
End Sub

Sub StopTimer()
    ' 動作停止
    Running = False
    
    ' ストップ時刻を記録
    Range("F3").Value = Now
    Range("F3").NumberFormat = "hh:mm:ss"
End Sub

Sub ResetTimer()
    ' 動作停止
    Running = False
    
    ' E3～G3 をクリア
    Range("E3:G3").ClearContents
End Sub

コードを入れるのはこの場所になります。

コードを入力したので、マクロをそれぞれ登録します。

スタートはStartTimerを登録、ストップはStopTimer、リセットはResetTimerです。ボタンをクリックすると以下のようにストップウォッチが動作するはずです。

12か月分のシートを自動生成するVBA

ボタンを押すだけで、1月?12月のシートを自動生成します。
各シートには氏名・収入・支出の項目が整形された状態で作成されます。

標準モジュールの先ほどのストップウォッチのコードの下に、以下のコードも追記します。

'===============================
' シート存在チェック関数
'===============================
Function SheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(sheetName)
    On Error GoTo 0
    SheetExists = Not ws Is Nothing
End Function


'===============================
' お題生成メイン処理
'===============================
Sub GenerateOdia()

    Dim names As Variant
    Dim income1 As Long, income2 As Long, otherIncome As Long
    Dim house As Long, food As Long, car As Long, insurance As Long
    Dim homePhone As Long, mobile As Long, tv As Long, net As Long
    Dim elec As Long, water As Long, gas As Long
    Dim entertainment As Long, education As Long, saving As Long

    Dim m As Long, i As Long
    Dim ws As Worksheet
    Dim checkCell As Range

    ' 氏名10人
    names = Array("黒子", "桜木", "黒崎", "夜神", "江戸川", _
                  "幕ノ内", "磯野", "緑谷", "花垣", "大空")

    ' お題生成シートのA1で作成済みチェック
    Set ws = Worksheets("お題生成")
    Set checkCell = ws.Range("A1")

    If checkCell.Value = "作成済み" Then
        MsgBox "すでにお題が作成されています。キャンセルします。", vbExclamation
        Exit Sub
    End If


    '===============================
    ' 1月～12月のシートを作成
    '===============================
    For m = 1 To 12

        ' すでに存在するかチェック
        If SheetExists(m & "月") Then
            MsgBox m & "月シートがすでに存在するため、お題生成をキャンセルします。", vbExclamation
            Exit Sub
        End If

        ' シート作成
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = m & "月"
        Set ws = Worksheets(m & "月")



        '===============================
        ' 項目（3行目）
        '===============================
        ws.Range("A3").Value = "氏名"
        ws.Range("B3").Value = "収入1"
        ws.Range("C3").Value = "収入2"
        ws.Range("D3").Value = "その他収入"
        ws.Range("E3").Value = "住居費"
        ws.Range("F3").Value = "食料品"
        ws.Range("G3").Value = "自動車ローン"
        ws.Range("H3").Value = "保険料"
        ws.Range("I3").Value = "自宅電話"
        ws.Range("J3").Value = "携帯電話代"
        ws.Range("K3").Value = "ケーブルTV"
        ws.Range("L3").Value = "インターネット"
        ws.Range("M3").Value = "電気"
        ws.Range("N3").Value = "水道"
        ws.Range("O3").Value = "ガス"
        ws.Range("P3").Value = "娯楽費"
        ws.Range("Q3").Value = "教育費"
        ws.Range("R3").Value = "貯蓄"

        ' 見出しのフォント設定
        ws.Range("A3:R3").Font.Name = "メイリオ"
        ws.Range("A3:R3").Font.Size = 7
        ws.Range("A3:R3").Font.Color = RGB(0, 0, 0)
        ws.Range("A3:R3").HorizontalAlignment = xlCenter

        ' 背景色（白、背景1、黒＋基本色15%）
        ws.Range("A3:R3").Interior.Color = RGB(217, 217, 217)


        '===============================
        ' 10人分のお題生成（4行目?）
        '===============================
        For i = 0 To 9

            ' ランダム収入
            income1 = WorksheetFunction.RandBetween(380000, 450000)
            income2 = WorksheetFunction.RandBetween(25000, 35000)
            otherIncome = WorksheetFunction.RandBetween(30000, 80000)

            ' ランダム支出
            house = 150000
            food = WorksheetFunction.RandBetween(25000, 35000)
            car = WorksheetFunction.RandBetween(34000, 36000)
            insurance = WorksheetFunction.RandBetween(12000, 13000)
            homePhone = WorksheetFunction.RandBetween(6000, 7000)
            mobile = WorksheetFunction.RandBetween(7000, 8000)
            tv = WorksheetFunction.RandBetween(4500, 6000)
            net = WorksheetFunction.RandBetween(4000, 5000)
            elec = WorksheetFunction.RandBetween(9000, 15000)
            water = WorksheetFunction.RandBetween(3500, 4500)
            gas = WorksheetFunction.RandBetween(5000, 7000)
            entertainment = WorksheetFunction.RandBetween(15000, 25000)
            education = WorksheetFunction.RandBetween(20000, 25000)
            saving = WorksheetFunction.RandBetween(20000, 30000)

            ' 書き込み
            ws.Cells(i + 4, 1).Value = names(i)
            ws.Cells(i + 4, 2).Value = income1
            ws.Cells(i + 4, 3).Value = income2
            ws.Cells(i + 4, 4).Value = otherIncome

            ws.Cells(i + 4, 5).Value = house
            ws.Cells(i + 4, 6).Value = food
            ws.Cells(i + 4, 7).Value = car
            ws.Cells(i + 4, 8).Value = insurance
            ws.Cells(i + 4, 9).Value = homePhone
            ws.Cells(i + 4, 10).Value = mobile
            ws.Cells(i + 4, 11).Value = tv
            ws.Cells(i + 4, 12).Value = net
            ws.Cells(i + 4, 13).Value = elec
            ws.Cells(i + 4, 14).Value = water
            ws.Cells(i + 4, 15).Value = gas
            ws.Cells(i + 4, 16).Value = entertainment
            ws.Cells(i + 4, 17).Value = education
            ws.Cells(i + 4, 18).Value = saving

        Next i

        '===============================
        ' 表示形式（通貨）
        '===============================
        ws.Range("B4:R13").NumberFormatLocal = "\#,##0"

        '===============================
        ' フォント設定（全体）
        '===============================
        ws.Cells.Font.Name = "メイリオ"
        ws.Cells.Font.Size = 7
        ws.Cells.Font.Color = RGB(0, 0, 0)
        
        '===============================
        ' 見出し（1行目）
        '===============================
        ws.Range("A1").Value = m & "月分 お題"
        ws.Range("A1").Font.Size = 22
        ws.Range("A1").Font.Name = "メイリオ"
       

        '===============================
        ' 行の高さ
        '===============================
        ws.Rows("3:13").RowHeight = 40

        '===============================
        ' 列幅（すべて7.3）
        '===============================
        ws.Columns("A:R").ColumnWidth = 7.3

        '===============================
        ' 罫線
        '===============================
        ws.Range("A3:R13").Borders.LineStyle = xlContinuous

        '===============================
        ' 印刷設定
        '===============================
        With ws.PageSetup
            .Orientation = xlLandscape
            .FitToPagesWide = 1
            .FitToPagesTall = 1
            .LeftMargin = 0
            .RightMargin = 0
            .CenterHorizontally = True
        End With

    Next m

    '===============================
    ' お題作成済みフラグ
    '===============================
    Worksheets("お題生成").Range("A1").Value = "作成済み"

    MsgBox "12か月分のお題を作成しました。", vbInformation

End Sub



Sub DeleteOdiaSheets()

    Dim m As Long
    Dim ws As Worksheet

    '===============================
    ' 1月シートが存在するか確認
    '===============================
    On Error Resume Next
    Set ws = Worksheets("1月")
    On Error GoTo 0

    If ws Is Nothing Then
        MsgBox "1月のシートがないためキャンセルします。", vbExclamation
        Exit Sub
    End If

    '===============================
    ' 削除確認メッセージ
    '===============================
    If MsgBox("1月～12月のシートを削除しますか？", vbOKCancel + vbQuestion) <> vbOK Then
        MsgBox "キャンセルしました。", vbInformation
        Exit Sub
    End If

    '===============================
    ' 1月?12月のシート削除
    '===============================
    Application.DisplayAlerts = False ' 削除確認を非表示

    For m = 1 To 12
        On Error Resume Next
        Set ws = Worksheets(m & "月")
        On Error GoTo 0

        If Not ws Is Nothing Then
            ws.Delete
        End If

        Set ws = Nothing
    Next m

    Application.DisplayAlerts = True

    '===============================
    ' お題生成シートのフラグを消す
    '===============================
    Worksheets("お題生成").Range("A1").ClearContents

    MsgBox "1月～12月のシートを削除しました。", vbInformation

End Sub

また、今回は「お題生成」というシートにボタンを配置し、先ほどのマクロを入れたいと思います。

マクロはGenerateOdiaを設定します。

また、お題を作った後にシートを削除することを効率化するため、削除シートボタンも作ってみましょう。こちらは先ほどのコードに実は入れていますので、そのままDeleteOdiaSheetsのマクロを登録します。

ボタンを実際に押してみましょう。

一気に1年分作られ、さらに削除シートボタンをクリックするとシートガ削除されると思います。

ちなみに氏名はアニメの名前の苗字で作ってみたのですが、コードの中にある氏名を変えても大丈夫です。

収入・支出のランダム生成ロジック

収入1・収入2・その他収入・住居費・食料品などの金額は、RandBetween 関数を使ってランダム生成します。
これにより、毎回異なる家計簿データを作成できます。

フォント・罫線・印刷設定の自動整形

フォントはメイリオ、背景色は「白、背景1、黒＋基本色15%」、列幅は 7.3 に統一。
印刷設定は横向き・左右余白0・1ページに収まるように自動調整されます。

シート削除ボタンの作成

先ほどのシート削除ボタンについても解説します。

1月～12月のシートを一括削除するVBA

「シート削除」ボタンを押すと、1月～12月のシートをまとめて削除できます。
削除前には確認メッセージが表示されるため、誤操作を防げます。

「作成済み」フラグをリセットする仕組み

お題生成シートの A1 にある「作成済み」の文字を削除し、再生成できる状態に戻します。

採点機能の作り方

ご利用者が実際にシートを作った後、採点も自動化するようにします。

まずは標準モジュールに以下のコードも追記します。

'以下は採点コード
Sub ScoreUser()

    Dim userSheet As Worksheet
    Dim scoreSheet As Worksheet
    Dim monthSheet As Worksheet
    Dim userName As String
    Dim sheetName As String
    Dim m As Long
    Dim correctCount As Long
    Dim missCount As Long
    Dim rO As Long
    Dim colU As Long
    Dim colO As Long
    Dim rowU As Long

    '===============================
    ' シート設定
    '===============================
    sheetName = ActiveSheet.Name
    Set userSheet = Worksheets(sheetName)
    Set scoreSheet = Worksheets("採点")

    '===============================
    ' 氏名チェック（B1）
    '===============================
    userName = userSheet.Range("B1").Value

    If userName = "" Then
        MsgBox "B1に氏名が入力されていません。キャンセルします。", vbExclamation
        Exit Sub
    End If

    If userName <> sheetName Then
        MsgBox userName & " の氏名とシート名が一致していないのでキャンセルします。", vbExclamation
        Exit Sub
    End If

    '===============================
    ' ★採点前にフォントを元に戻す（重要）
    '===============================
    For rowU = 8 To 27
        For colU = 3 To 14 ' C?N列（1月?12月）
            With userSheet.Cells(rowU, colU)
                .Font.Color = RGB(0, 0, 0)
                .Font.Bold = False
                .Font.Size = 7
            End With
        Next colU
    Next rowU

    '===============================
    ' 採点開始
    '===============================
    correctCount = 0
    missCount = 0

    ' 採点日入力
    scoreSheet.Range("D10").Value = Date

    '===============================
    ' お題シートの氏名行を探す（4?13行）
    '===============================
    For rO = 4 To 13
        If Worksheets("1月").Cells(rO, 1).Value = userName Then Exit For
    Next rO

    If rO > 13 Then
        MsgBox "お題シートに氏名がありません。", vbExclamation
        Exit Sub
    End If

    '===============================
    ' 1月～12月の採点
    '===============================
    For m = 1 To 12

        Set monthSheet = Worksheets(m & "月")

        ' 利用者シートの月列（1月＝C列＝3）
        colU = 2 + m

        '===============================
        ' 収入系（8～10行）
        '===============================
        For rowU = 8 To 10

            colO = rowU - 6 ' 8→2(B列), 9→3(C列), 10→4(D列)

            If userSheet.Cells(rowU, colU).Value = monthSheet.Cells(rO, colO).Value Then
                correctCount = correctCount + 1
            Else
                missCount = missCount + 1
                With userSheet.Cells(rowU, colU)
                    .Font.Color = RGB(255, 0, 0)
                    .Font.Bold = True
                End With
            End If

        Next rowU

        '===============================
        ' 支出系（14～27行）
        '===============================
        For rowU = 14 To 27

            colO = rowU - 9 ' 14→5(E列), 15→6(F列)…27→18(R列)

            If userSheet.Cells(rowU, colU).Value = monthSheet.Cells(rO, colO).Value Then
                correctCount = correctCount + 1
            Else
                missCount = missCount + 1
                With userSheet.Cells(rowU, colU)
                    .Font.Color = RGB(255, 0, 0)
                    .Font.Bold = True
                End With
            End If

        Next rowU

    Next m

    '===============================
    ' 採点結果を採点シートへ
    '===============================
    Dim idx As Variant
    idx = Application.Match(userName, scoreSheet.Range("A15:A24"), 0)

    If Not IsError(idx) Then
        scoreSheet.Cells(14 + idx, 2).Value = correctCount
        scoreSheet.Cells(14 + idx, 3).Value = missCount
    Else
        MsgBox "採点シートに氏名がありません。", vbExclamation
    End If

    MsgBox "採点完了：正解 " & correctCount & " ／ ミス " & missCount, vbInformation

End Sub

シートに採点ボタンも配置し、ScoreUserマクロも登録します。

ご利用者が作業するシートは、家計簿シートを複製し、シート名を氏名にします。また、B1のセルを氏名として入力してもらい、C1のセルは家の家計簿と入力してください。

採点シートの作成

上記のように、採点シートを作成します。

ここまでの内容について解説します。

氏名チェック（B1セルとシート名の一致）

利用者シートの B1 に入力された氏名と、シート名が一致しているか確認します。
一致しない場合は採点をキャンセルし、誤採点を防ぎます。

お題シートと利用者シートの照合ロジック

収入1～貯蓄の項目を、1月～12月の各お題シートと照合します。
項目ごとに正しいセル番地をマッピングし、正確に比較できるようにしています。

間違い箇所を赤字太字にする方法

不一致だったセルは赤字＋太字に変更し、どこが間違っていたか一目で分かるようにします。

採点結果を採点シートへ自動記録する方法

正解数・ミス数を採点シートの B15～C24 に自動で記録します。
正解率や合計は数式で自動計算されます。

採点前にフォントをリセットする仕組み

採点前に、利用者シートのフォントを黒・通常サイズ・太字解除に戻します。
これにより、前回の採点結果が残らないようにできます。

全員分を一括採点する「全て採点」ボタン

以下のコードをコピペして追記しましょう。

'すべてのsheet採点
Sub ScoreAllUsers()

    Dim names As Variant
    Dim i As Long
    Dim ws As Worksheet

    ' 採点する氏名リスト
    names = Array("黒子", "桜木", "黒崎", "夜神", "江戸川", _
                  "幕ノ内", "磯野", "緑谷", "花垣", "大空")

    MsgBox "全て採点を開始します。少し時間がかかる場合があります。", vbInformation

    ' 氏名ごとに採点
    For i = 0 To UBound(names)

        On Error Resume Next
        Set ws = Worksheets(names(i))
        On Error GoTo 0

        If Not ws Is Nothing Then
            ws.Activate
            Call ScoreUser   ' ← 既存の採点マクロを呼び出す
        End If

        Set ws = Nothing

    Next i

    MsgBox "全ての採点が完了しました。", vbInformation

End Sub

全て採点ボタンに、ScoreAllUsersのマクロを登録します。

これまでのコードの意味は以下となります。

10人のシートを順番に探して採点するVBA

黒子 → 桜木 → 黒崎 → 夜神 → 江戸川 → 幕ノ内 → 磯野 → 緑谷 → 花垣 → 大空
の順番でシートを探し、存在すれば採点します。

採点マクロ（ScoreUser）との連携方法

ScoreAllUsers マクロ内で ScoreUser を呼び出すことで、既存の採点ロジックをそのまま使いながら一括採点を実現しています。

採点完了メッセージの表示

全員分の採点が終わると、完了メッセージが表示されます。支援員が採点状況を確認しやすくなります。

完成した訓練ツールの使い方

支援現場での運用例

利用者に家計簿入力をしてもらい、ストップウォッチで時間を計測しながら訓練を行います。
採点結果は支援記録にも活用できます。

利用者の習熟度に合わせた難易度調整

収入・支出の項目数を増やしたり、金額の幅を調整することで難易度を変えられます。

ストップウォッチと組み合わせた訓練方法

入力時間と正確性の両方を評価できるため、より実務に近い訓練が可能になります。

完成形のコード

ここまで何度も追記したりしたので、ストップウォッチから最後まで全てのコードの完成形を出します。

もしうまくいかない場合は、一旦下記のコードを全てコピペして標準モジュールに入れてみましょう。

Public StartTime As Date
Public Running As Boolean

Sub StartTimer()
    ' リセットして開始
    ResetTimer
    
    ' スタート時刻を記録
    StartTime = Now
    Range("E3").Value = StartTime
    Range("E3").NumberFormat = "hh:mm:ss"
    
    ' 動作中フラグを立てる
    Running = True
    
    ' 経過時間のリアルタイム更新開始
    UpdateTimer
End Sub

Sub UpdateTimer()
    ' 停止中なら更新しない
    If Running = False Then Exit Sub
    
    ' 経過時間を表示
    Range("G3").Value = Now - StartTime
    Range("G3").NumberFormat = "hh:mm:ss"
    
    ' 次の更新を予約（1秒ごと）
    Application.OnTime Now + TimeValue("00:00:01"), "UpdateTimer"
End Sub

Sub StopTimer()
    ' 動作停止
    Running = False
    
    ' ストップ時刻を記録
    Range("F3").Value = Now
    Range("F3").NumberFormat = "hh:mm:ss"
End Sub

Sub ResetTimer()
    ' 動作停止
    Running = False
    
    ' E3～G3 をクリア
    Range("E3:G3").ClearContents
End Sub



'===============================
' シート存在チェック関数
'===============================
Function SheetExists(sheetName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(sheetName)
    On Error GoTo 0
    SheetExists = Not ws Is Nothing
End Function


'===============================
' お題生成メイン処理
'===============================
Sub GenerateOdia()

    Dim names As Variant
    Dim income1 As Long, income2 As Long, otherIncome As Long
    Dim house As Long, food As Long, car As Long, insurance As Long
    Dim homePhone As Long, mobile As Long, tv As Long, net As Long
    Dim elec As Long, water As Long, gas As Long
    Dim entertainment As Long, education As Long, saving As Long

    Dim m As Long, i As Long
    Dim ws As Worksheet
    Dim checkCell As Range

    ' 氏名10人
    names = Array("黒子", "桜木", "黒崎", "夜神", "江戸川", _
                  "幕ノ内", "磯野", "緑谷", "花垣", "大空")

    ' お題生成シートのA1で作成済みチェック
    Set ws = Worksheets("お題生成")
    Set checkCell = ws.Range("A1")

    If checkCell.Value = "作成済み" Then
        MsgBox "すでにお題が作成されています。キャンセルします。", vbExclamation
        Exit Sub
    End If


    '===============================
    ' 1月?12月のシートを作成
    '===============================
    For m = 1 To 12

        ' すでに存在するかチェック
        If SheetExists(m & "月") Then
            MsgBox m & "月シートがすでに存在するため、お題生成をキャンセルします。", vbExclamation
            Exit Sub
        End If

        ' シート作成
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = m & "月"
        Set ws = Worksheets(m & "月")



        '===============================
        ' 項目（3行目）
        '===============================
        ws.Range("A3").Value = "氏名"
        ws.Range("B3").Value = "収入1"
        ws.Range("C3").Value = "収入2"
        ws.Range("D3").Value = "その他収入"
        ws.Range("E3").Value = "住居費"
        ws.Range("F3").Value = "食料品"
        ws.Range("G3").Value = "自動車ローン"
        ws.Range("H3").Value = "保険料"
        ws.Range("I3").Value = "自宅電話"
        ws.Range("J3").Value = "携帯電話代"
        ws.Range("K3").Value = "ケーブルTV"
        ws.Range("L3").Value = "インターネット"
        ws.Range("M3").Value = "電気"
        ws.Range("N3").Value = "水道"
        ws.Range("O3").Value = "ガス"
        ws.Range("P3").Value = "娯楽費"
        ws.Range("Q3").Value = "教育費"
        ws.Range("R3").Value = "貯蓄"

        ' 見出しのフォント設定
        ws.Range("A3:R3").Font.Name = "メイリオ"
        ws.Range("A3:R3").Font.Size = 7
        ws.Range("A3:R3").Font.Color = RGB(0, 0, 0)
        ws.Range("A3:R3").HorizontalAlignment = xlCenter

        ' 背景色（白、背景1、黒＋基本色15%）
        ws.Range("A3:R3").Interior.Color = RGB(217, 217, 217)


        '===============================
        ' 10人分のお題生成（4行目?）
        '===============================
        For i = 0 To 9

            ' ランダム収入
            income1 = WorksheetFunction.RandBetween(380000, 450000)
            income2 = WorksheetFunction.RandBetween(25000, 35000)
            otherIncome = WorksheetFunction.RandBetween(30000, 80000)

            ' ランダム支出
            house = 150000
            food = WorksheetFunction.RandBetween(25000, 35000)
            car = WorksheetFunction.RandBetween(34000, 36000)
            insurance = WorksheetFunction.RandBetween(12000, 13000)
            homePhone = WorksheetFunction.RandBetween(6000, 7000)
            mobile = WorksheetFunction.RandBetween(7000, 8000)
            tv = WorksheetFunction.RandBetween(4500, 6000)
            net = WorksheetFunction.RandBetween(4000, 5000)
            elec = WorksheetFunction.RandBetween(9000, 15000)
            water = WorksheetFunction.RandBetween(3500, 4500)
            gas = WorksheetFunction.RandBetween(5000, 7000)
            entertainment = WorksheetFunction.RandBetween(15000, 25000)
            education = WorksheetFunction.RandBetween(20000, 25000)
            saving = WorksheetFunction.RandBetween(20000, 30000)

            ' 書き込み
            ws.Cells(i + 4, 1).Value = names(i)
            ws.Cells(i + 4, 2).Value = income1
            ws.Cells(i + 4, 3).Value = income2
            ws.Cells(i + 4, 4).Value = otherIncome

            ws.Cells(i + 4, 5).Value = house
            ws.Cells(i + 4, 6).Value = food
            ws.Cells(i + 4, 7).Value = car
            ws.Cells(i + 4, 8).Value = insurance
            ws.Cells(i + 4, 9).Value = homePhone
            ws.Cells(i + 4, 10).Value = mobile
            ws.Cells(i + 4, 11).Value = tv
            ws.Cells(i + 4, 12).Value = net
            ws.Cells(i + 4, 13).Value = elec
            ws.Cells(i + 4, 14).Value = water
            ws.Cells(i + 4, 15).Value = gas
            ws.Cells(i + 4, 16).Value = entertainment
            ws.Cells(i + 4, 17).Value = education
            ws.Cells(i + 4, 18).Value = saving

        Next i

        '===============================
        ' 表示形式（通貨）
        '===============================
        ws.Range("B4:R13").NumberFormatLocal = "\#,##0"

        '===============================
        ' フォント設定（全体）
        '===============================
        ws.Cells.Font.Name = "メイリオ"
        ws.Cells.Font.Size = 7
        ws.Cells.Font.Color = RGB(0, 0, 0)
        
        '===============================
        ' 見出し（1行目）
        '===============================
        ws.Range("A1").Value = m & "月分 お題"
        ws.Range("A1").Font.Size = 22
        ws.Range("A1").Font.Name = "メイリオ"
       

        '===============================
        ' 行の高さ
        '===============================
        ws.Rows("3:13").RowHeight = 40

        '===============================
        ' 列幅（すべて7.3）
        '===============================
        ws.Columns("A:R").ColumnWidth = 7.3

        '===============================
        ' 罫線
        '===============================
        ws.Range("A3:R13").Borders.LineStyle = xlContinuous

        '===============================
        ' 印刷設定
        '===============================
        With ws.PageSetup
            .Orientation = xlLandscape
            .FitToPagesWide = 1
            .FitToPagesTall = 1
            .LeftMargin = 0
            .RightMargin = 0
            .CenterHorizontally = True
        End With

    Next m

    '===============================
    ' お題作成済みフラグ
    '===============================
    Worksheets("お題生成").Range("A1").Value = "作成済み"

    MsgBox "12か月分のお題を作成しました。", vbInformation

End Sub



Sub DeleteOdiaSheets()

    Dim m As Long
    Dim ws As Worksheet

    '===============================
    ' 1月シートが存在するか確認
    '===============================
    On Error Resume Next
    Set ws = Worksheets("1月")
    On Error GoTo 0

    If ws Is Nothing Then
        MsgBox "1月のシートがないためキャンセルします。", vbExclamation
        Exit Sub
    End If

    '===============================
    ' 削除確認メッセージ
    '===============================
    If MsgBox("1月～12月のシートを削除しますか？", vbOKCancel + vbQuestion) <> vbOK Then
        MsgBox "キャンセルしました。", vbInformation
        Exit Sub
    End If

    '===============================
    ' 1月?12月のシート削除
    '===============================
    Application.DisplayAlerts = False ' 削除確認を非表示

    For m = 1 To 12
        On Error Resume Next
        Set ws = Worksheets(m & "月")
        On Error GoTo 0

        If Not ws Is Nothing Then
            ws.Delete
        End If

        Set ws = Nothing
    Next m

    Application.DisplayAlerts = True

    '===============================
    ' お題生成シートのフラグを消す
    '===============================
    Worksheets("お題生成").Range("A1").ClearContents

    MsgBox "1月～12月のシートを削除しました。", vbInformation

End Sub




'以下は採点コード
Sub ScoreUser()

    Dim userSheet As Worksheet
    Dim scoreSheet As Worksheet
    Dim monthSheet As Worksheet
    Dim userName As String
    Dim sheetName As String
    Dim m As Long
    Dim correctCount As Long
    Dim missCount As Long
    Dim rO As Long
    Dim colU As Long
    Dim colO As Long
    Dim rowU As Long

    '===============================
    ' シート設定
    '===============================
    sheetName = ActiveSheet.Name
    Set userSheet = Worksheets(sheetName)
    Set scoreSheet = Worksheets("採点")

    '===============================
    ' 氏名チェック（B1）
    '===============================
    userName = userSheet.Range("B1").Value

    If userName = "" Then
        MsgBox "B1に氏名が入力されていません。キャンセルします。", vbExclamation
        Exit Sub
    End If

    If userName <> sheetName Then
        MsgBox userName & " の氏名とシート名が一致していないのでキャンセルします。", vbExclamation
        Exit Sub
    End If

    '===============================
    ' ★採点前にフォントを元に戻す（重要）
    '===============================
    For rowU = 8 To 27
        For colU = 3 To 14 ' C?N列（1月?12月）
            With userSheet.Cells(rowU, colU)
                .Font.Color = RGB(0, 0, 0)
                .Font.Bold = False
                .Font.Size = 7
            End With
        Next colU
    Next rowU

    '===============================
    ' 採点開始
    '===============================
    correctCount = 0
    missCount = 0

    ' 採点日入力
    scoreSheet.Range("D10").Value = Date

    '===============================
    ' お題シートの氏名行を探す（4?13行）
    '===============================
    For rO = 4 To 13
        If Worksheets("1月").Cells(rO, 1).Value = userName Then Exit For
    Next rO

    If rO > 13 Then
        MsgBox "お題シートに氏名がありません。", vbExclamation
        Exit Sub
    End If

    '===============================
    ' 1月?12月の採点
    '===============================
    For m = 1 To 12

        Set monthSheet = Worksheets(m & "月")

        ' 利用者シートの月列（1月＝C列＝3）
        colU = 2 + m

        '===============================
        ' 収入系（8?10行）
        '===============================
        For rowU = 8 To 10

            colO = rowU - 6 ' 8→2(B列), 9→3(C列), 10→4(D列)

            If userSheet.Cells(rowU, colU).Value = monthSheet.Cells(rO, colO).Value Then
                correctCount = correctCount + 1
            Else
                missCount = missCount + 1
                With userSheet.Cells(rowU, colU)
                    .Font.Color = RGB(255, 0, 0)
                    .Font.Bold = True
                End With
            End If

        Next rowU

        '===============================
        ' 支出系（14?27行）
        '===============================
        For rowU = 14 To 27

            colO = rowU - 9 ' 14→5(E列), 15→6(F列)…27→18(R列)

            If userSheet.Cells(rowU, colU).Value = monthSheet.Cells(rO, colO).Value Then
                correctCount = correctCount + 1
            Else
                missCount = missCount + 1
                With userSheet.Cells(rowU, colU)
                    .Font.Color = RGB(255, 0, 0)
                    .Font.Bold = True
                End With
            End If

        Next rowU

    Next m

    '===============================
    ' 採点結果を採点シートへ
    '===============================
    Dim idx As Variant
    idx = Application.Match(userName, scoreSheet.Range("A15:A24"), 0)

    If Not IsError(idx) Then
        scoreSheet.Cells(14 + idx, 2).Value = correctCount
        scoreSheet.Cells(14 + idx, 3).Value = missCount
    Else
        MsgBox "採点シートに氏名がありません。", vbExclamation
    End If

    MsgBox "採点完了：正解 " & correctCount & " ／ ミス " & missCount, vbInformation

End Sub

'すべてのsheet採点
Sub ScoreAllUsers()

    Dim names As Variant
    Dim i As Long
    Dim ws As Worksheet

    ' 採点する氏名リスト
    names = Array("黒子", "桜木", "黒崎", "夜神", "江戸川", _
                  "幕ノ内", "磯野", "緑谷", "花垣", "大空")

    MsgBox "全て採点を開始します。少し時間がかかる場合があります。", vbInformation

    ' 氏名ごとに採点
    For i = 0 To UBound(names)

        On Error Resume Next
        Set ws = Worksheets(names(i))
        On Error GoTo 0

        If Not ws Is Nothing Then
            ws.Activate
            Call ScoreUser   ' ← 既存の採点マクロを呼び出す
        End If

        Set ws = Nothing

    Next i

    MsgBox "全ての採点が完了しました。", vbInformation

End Sub