ナンプレ解析はExcelに任せよう！プレゼント応募？そんなのオマケや（笑）

■関連記事
Excelで本格ナンプレを作ろう！〜自動生成・難易度別問題・正解チェックまで完全網羅〜

---

---

---

🧱これが我が家のナンプレフォーマットじゃい！

---

---

---

🧠解析開始！ジッピーが数字の迷宮をぶち破る！

---

🗯️マクロがやってることをざっくり言うと…

• 入力された盤面（B3:J11）を9×9の配列に読み取り
• バックトラッキング法でガチ解析
• 解けたら即反映！自動で色もつけて「ジッピーが頑張った感」演出
• 解けなかった場合は、やさし〜く「入力ミスないですか？」と問いかける（笑）

---

📜VBAコードはこちら

Sub ナンプレ解析()
    Dim i As Long, j As Long
    Dim board(1 To 9, 1 To 9) As Integer
    Dim startRange As Range
    Set startRange = Sheets("問題").Range("B3")

    ' 入力値を取得
    For i = 1 To 9
        For j = 1 To 9
            If IsNumeric(startRange.Cells(i, j).Value) Then
                board(i, j) = startRange.Cells(i, j).Value
            Else
                board(i, j) = 0
            End If
        Next j
    Next i

    ' 重複チェック
    If Not IsInitialValidRange(startRange.Resize(9, 9)) Then
        MsgBox "解析できません。入力に重複があります！", vbExclamation
        Exit Sub
    End If

    ' 解けるか試行
    If SolveSudoku(board) Then
        For i = 1 To 9
            For j = 1 To 9
                With startRange.Cells(i, j)
                    If .Value = "" Then
                        .Value = board(i, j)
                        .Interior.Color = RGB(235, 241, 222)
                        .Font.Color = RGB(0, 112, 192)
                    End If
                End With
            Next j
        Next i
        MsgBox "解析完了！すべてのマスが埋まりました。", vbInformation
    Else
        MsgBox "解析できません。入力ミスはありませんか？", vbExclamation
    End If
End Sub

---

🧩ロジックの心臓部たち

Function SolveSudoku(ByRef board() As Integer) As Boolean
    Dim row As Integer, col As Integer
    If Not FindEmptyCell(board, row, col) Then
        SolveSudoku = True
        Exit Function
    End If

    Dim num As Integer
    For num = 1 To 9
        If IsValid(board, row, col, num) Then
            board(row, col) = num
            If SolveSudoku(board) Then
                SolveSudoku = True
                Exit Function
            End If
            board(row, col) = 0
        End If
    Next num

    SolveSudoku = False
End Function

Function FindEmptyCell(board() As Integer, ByRef row As Integer, ByRef col As Integer) As Boolean
    Dim i As Integer, j As Integer
    For i = 1 To 9
        For j = 1 To 9
            If board(i, j) = 0 Then
                row = i: col = j
                FindEmptyCell = True
                Exit Function
            End If
        Next j
    Next i
    FindEmptyCell = False
End Function

Function IsValid(board() As Integer, row As Integer, col As Integer, num As Integer) As Boolean
    Dim i As Integer, j As Integer
    ' 行と列チェック
    For i = 1 To 9
        If board(row, i) = num Or board(i, col) = num Then
            IsValid = False
            Exit Function
        End If
    Next i
    ' 3x3ブロックチェック
    Dim startRow As Integer, startCol As Integer
    startRow = ((row - 1) \ 3) * 3 + 1
    startCol = ((col - 1) \ 3) * 3 + 1
    For i = 0 To 2
        For j = 0 To 2
            If board(startRow + i, startCol + j) = num Then
                IsValid = False
                Exit Function
            End If
        Next j
    Next i
    IsValid = True
End Function

Function IsInitialValidRange(rng As Range) As Boolean
    Dim i As Long, j As Long
    Dim r As Long, c As Long
    Dim dict As Object
    Dim num As Variant

    ' 行チェック
    For r = 1 To 9
        Set dict = CreateObject("Scripting.Dictionary")
        For c = 1 To 9
            num = rng.Cells(r, c).Value
            If IsNumeric(num) And num <> 0 Then
                If dict.exists(num) Then
                    IsInitialValidRange = False
                    Exit Function
                Else
                    dict.Add num, True
                End If
            End If
        Next c
    Next r

    ' 列チェック
    For c = 1 To 9
        Set dict = CreateObject("Scripting.Dictionary")
        For r = 1 To 9
            num = rng.Cells(r, c).Value
            If IsNumeric(num) And num <> 0 Then
                If dict.exists(num) Then
                    IsInitialValidRange = False
                    Exit Function
                Else
                    dict.Add num, True
                End If
            End If
        Next r
    Next c

    ' 3x3ブロックチェック
    Dim br As Long, bc As Long
    For br = 0 To 2
        For bc = 0 To 2
            Set dict = CreateObject("Scripting.Dictionary")
            For i = 1 To 3
                For j = 1 To 3
                    r = br * 3 + i
                    c = bc * 3 + j
                    num = rng.Cells(r, c).Value
                    If IsNumeric(num) And num <> 0 Then
                        If dict.exists(num) Then
                            IsInitialValidRange = False
                            Exit Function
                        Else
                            dict.Add num, True
                        End If
                    End If
                Next j
            Next i
        Next bc
    Next br

    IsInitialValidRange = True
End Function

---

---

---

---

---

---

---

🕵️‍ 答えチェックの演出に全振りしてみた件

🎯「解析結果？それより演出やろ！」

---

💡 答えチェックのマクロはこちら！

Sub 答えチェック()

    Dim ws As Worksheet
    Set ws = Sheets("問題")

    ' 色初期化（まずはまっさらの盤面に）
    ws.Range("B3:J11").Interior.ColorIndex = xlNone
    
    '  行チェック（奇数行を緑に）
    MsgBox "行 OK！", vbInformation
    Dim r As Long
    For r = 1 To 9 Step 2
        ws.Range("B" & r + 2 & ":J" & r + 2).Interior.Color = RGB(226, 239, 218) ' 薄緑
    Next r

    '  列チェック（奇数列を水色に）
    MsgBox "列 OK！", vbInformation
    Dim c As Variant
    For Each c In Array("B", "D", "F", "H", "J")
        ws.Range(c & "3:" & c & "11").Interior.Color = RGB(221, 235, 247) ' 薄水色
    Next c

    '  ブロックチェック（特徴的な位置にピンクを）
    MsgBox "枠 OK！", vbInformation
    Dim area As Variant
    area = Array("B3:D5", "H3:J5", "E6:G8", "B9:D11", "H9:J11")
    Dim i As Long
    For i = 0 To UBound(area)
        ws.Range(area(i)).Interior.Color = RGB(242, 220, 219) ' 薄ピンク
    Next i

    '  最終メッセージ
    MsgBox "よし、行ってこい！", vbInformation

End Sub

---

📌 補足ポイント

• 演出が目的なので、「実際の正解チェック」は行っていません。
• 盤面が全て埋まった後に使うと雰囲気UP！✨
• 「行」「列」「枠」の順に、色が変わっていく演出でワクワク感を演出。
• ブロック色は、中央や端っこの特徴的な5ブロックに限定。

---

---

---

---

---

💾保存ボタンぽちで履歴もバッチリ！応募準備完了や！

---

✍️ 解析だけで満足してないやろ？

---

🔧 保存マクロのコードはこちら！

Sub ナンプレ保存()

    Dim wsSrc As Worksheet, wsDst As Worksheet
    Set wsSrc = Sheets("問題")
    Set wsDst = Sheets("保存履歴")

    Dim lastRow As Long
    lastRow = wsDst.Cells(wsDst.Rows.Count, 2).End(xlUp).Row

    ' 初回だけ例外処理
    If lastRow < 1 Then lastRow = 0

    Dim pasteRow As Long
    If lastRow = 0 Then
        pasteRow = 1
    Else
        pasteRow = lastRow + 2 ' 1行空けて追記
    End If

    ' 日時を先に書き込み
    wsDst.Cells(pasteRow, 2).Value = "■保存日時: " & Format(Now, "yyyy/m/d/h:mm:ss")

    ' 盤面データをコピー
    Dim r As Long, c As Long
    For r = 0 To 8
        For c = 0 To 8
            With wsDst.Cells(pasteRow + 1 + r, 2 + c)
                .Value = wsSrc.Cells(3 + r, 2 + c).Value
                .Font.Color = wsSrc.Cells(3 + r, 2 + c).Font.Color
                .Font.Name = wsSrc.Cells(3 + r, 2 + c).Font.Name
                .Font.Size = wsSrc.Cells(3 + r, 2 + c).Font.Size
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter

                ' 罫線コピー（上下左右）
                Dim side As Variant
                For Each side In Array(xlEdgeTop, xlEdgeBottom, xlEdgeLeft, xlEdgeRight)
                    With .Borders(side)
                        .LineStyle = wsSrc.Cells(3 + r, 2 + c).Borders(side).LineStyle
                        .Weight = wsSrc.Cells(3 + r, 2 + c).Borders(side).Weight
                        .Color = wsSrc.Cells(3 + r, 2 + c).Borders(side).Color
                    End With
                Next side
            End With
        Next c
    Next r

    MsgBox "保存完了！履歴に追加されました。", vbInformation

End Sub

---

🖱️ ボタン登録も忘れずに！

保存ボタンにこのマクロを登録してね👇

• ボタン右クリック → 「マクロの登録」
• 一覧から「ナンプレ保存」を選んでOK！

---

💡 補足メモ

• 上書きじゃなく追加式だから、いくらでも保存OK
• 空白でも保存されるので、解析後に保存がベスト
• 背景色はコピーしない仕様。強調表示や解析跡を省いて見やすく履歴化される！

---

📸 ここでスクショ撮りたくなる演出！

---

---

---

---

---

---

---

♻️リセットは正義！やり直し上等！

---

💬 どんなときに使う？

• 入力ミスしちゃった！
• 違う問題に挑戦したい！
• 保存し忘れてもう一回やり直したい！

そんなときは…
🧽 リセットボタンで全消去！

---

🔧 リセットマクロのコード

Sub ナンプレリセット()

    Dim rng As Range
    Set rng = Sheets("問題").Range("B3:J11")

    Dim cell As Range
    For Each cell In rng
        cell.ClearContents                ' 値を消す
        cell.Interior.ColorIndex = xlNone ' 背景色をクリア
        cell.Font.Color = RGB(0, 0, 0)    ' フォントカラーを黒に戻す
    Next cell

    MsgBox "リセット完了！盤面を初期状態に戻しました。", vbInformation

End Sub

---

🖱️ マクロ登録手順

ボタンを右クリック → 「マクロの登録」から
ナンプレリセット を選択してOK！

---

✅ 実行すると…

• 数字が全部消える！
• セルの背景色（演出）も真っ白に！
• 青文字だった解析数字も黒に！

すっきり初期状態✨
これでまた別の問題にチャレンジ可能！

---

📸 リセット後のスクショ活用

---

---

---

---

---

🎤最後にひとこと「解けなくても、解けるフリはできる（笑）

---

---

• 🧠 難解な盤面でも一瞬でズバッと解析！
• 🕵️‍ チェック機能で“確認しました感”の演出もバッチリ！
• 💾 保存履歴で解析の成果をしっかりキープ！
• ♻️ リセットでいつでもスタート地点へ！

---

😭 おまけ（NG集）

NG 1　セルの参照範囲を間違える

---

---

---

NG ２　C3の呪い

---

NG ３　地獄のエラー祭り

---

---

---

---

おしまい