もりさんのプログラミング手帳

教えることは、二度学ぶこと

スポンサーリンク

【連載・最終回】VBAでナンプレ(数独)を解いてみよう⑦<まとめ>

VBAでナンプレを解いてみよう【最終回】です。

f:id:excel-accounting:20180511135041p:plain:w400

連載記事の一覧はこちら→【VBAナンプレ連載】


解き方

全3つの解き方を実装しました。

解法1

「1つのセル」を解読対象として、そのセルに入る数字を探す方法です。

f:id:excel-accounting:20180618151802p:plain:w350

解法2

「3×3エリア」を解読対象として、まだ存在しない数字がどのセルに入るか探す方法です。

f:id:excel-accounting:20180618151642p:plain:w350

解法3(行・列)

「行」「列」を解読対象として、まだ存在しない数字がどのセルに入るか探す方法です。

f:id:excel-accounting:20180530205023p:plain:w350

f:id:excel-accounting:20180614224406p:plain:w350

パズルを解いてみる

エクセルシートのA1:I9セルに9×9のパズルを用意してマクロを実行します。

速いですね!

ソースコード

これまでの連載記事で作成してきたプログラムをまとめて掲載します。

興味のある方は遊んでみてくださいね!

モジュール構成

4つのモジュールを作成しました。
関連図は下記のとおりです。

f:id:excel-accounting:20180531230927p:plain:w400

共通モジュール

Option Explicit

Public r As Long, c As Long '現在地の行列番号
Public r1 As Long, c1 As Long 'BlockArea始点セルの行列番号
Public num As Long '1~9の数字

Sub VBAでナンプレを解く() '全体処理

    Application.ScreenUpdating = False

    Dim PuzzleArea As Range
    Set PuzzleArea = Range("A1:I9")
    
    Do '【ループ1】開始
    
        Dim BlankCnt1 As Long 'ループ2開始前の空白セル数
        BlankCnt1 = WorksheetFunction.CountBlank(PuzzleArea)

        For r = 1 To 9 '【ループ2】開始
            For c = 1 To 9
            
                'BlockArea始点セルの特定
                r1 = SearchBlockArea(r)
                c1 = SearchBlockArea(c)
                
                '解法1を呼び出す
                If Cells(r, c).Value = "" Then Call Solution1
                
                '解法2を呼び出す
                If (r = 1 Or r = 4 Or r = 7) And _
                    (c = 1 Or c = 4 Or c = 7) Then Call Solution2
            
                '解法3(行)を呼び出す
                If c = 1 Then Call Solution3_Row
                
                '解法3(列)を呼び出す
                If r = 1 Then Call Solution3_Col

            Next c
        Next r
        
        Dim BlankCnt2 As Long 'ループ2終了後の空白セル数
        BlankCnt2 = WorksheetFunction.CountBlank(PuzzleArea)
        
        If BlankCnt1 = BlankCnt2 Then
            MsgBox "お手上げ!終了します。"
            Exit Sub
        End If
    
    Loop Until WorksheetFunction.CountBlank(PuzzleArea) = 0
    
End Sub

Function SearchBlockArea(x As Long) As Long
'-------------------------------------------------------------------
' * 機能:BlockArea(3×3のエリア)の始点セルを特定する
' * 引数:現在地の【行番号(r)】または【列番号(c)】
' * 返り値:BlockArea始点セルの行番号または左端の列番号
'-------------------------------------------------------------------

    Select Case x
        
        Case 1, 4, 7
            SearchBlockArea = x
        Case 2, 5, 8
            SearchBlockArea = x - 1
        Case 3, 6, 9
            SearchBlockArea = x - 2

    End Select

End Function

Function isExistNum _
    (ByVal y1 As Long, x1 As Long, y2 As Long, x2 As Long) As Boolean
' --------------------------------------------------------------------------
' * 機能:[指定のセル範囲]にnumが存在するか検索する
' * 引数:始点セルの【行番号】,【列番号】と終点セルの【行番号】,【列番号】
' * 返り値:numが見つかった場合に【True】を返す
' --------------------------------------------------------------------------

    Dim result As Range
    Set result = Range(Cells(y1, x1), Cells(y2, x2)). _
                            Find(what:=num, LookAt:=xlWhole)
    
    'numが見つかったらTrueを返す
    If Not result Is Nothing Then isExistNum = True

End Function

Sub AnswerSet(ByVal y As Long, x As Long, answer As Long)
' ------------------------------------------------------------------
' * 機能:指定のセルに解答数字を代入する
' * 引数:【セルの行番号】,【セルの列番号】,【解答数字】
' ------------------------------------------------------------------

    With Cells(y, x)
        .Value = answer
        .Font.Bold = True '太字
        .Font.ColorIndex = 3 '赤
    End With
    
End Sub

解法1モジュール

Option Explicit
Option Base 1

Sub Solution1()

    Dim CheckFlag(9) As Boolean

    For num = 1 To 9 '【ループ1】
        
        Dim check1 As Boolean, check2 As Boolean, check3 As Boolean
        
        check1 = isExistNum(r1, c1, r1 + 2, c1 + 2) '①BlockAreaの検索
        check2 = isExistNum(r, 1, r, 9) '②横方向(行)の検索
        check3 = isExistNum(1, c, 9, c) '③縦方向(列)の検索
        
        '①②③のいずれかにnumが見つかったらFlagをTrueにする
        If check1 = True Or check2 = True Or check3 = True Then
            CheckFlag(num) = True
        End If
    
    Next num

    For num = 1 To 9 '【ループ2】
    
        If CheckFlag(num) = False Then
        
            Dim cnt As Long 'Falseの数をカウント
            cnt = cnt + 1
            
            Dim answer As Long '解答候補
            answer = num
        
        End If
    
    Next num
    
    If cnt = 1 Then '解答決定ならセルへ書き込み
        Call AnswerSet(r, c, answer)
    End If
    
End Sub

解法2モジュール

Option Explicit
Option Base 1

Sub Solution2()

    Dim BlockArea As Range
    Set BlockArea = Range(Cells(r1, c1), Cells(r1 + 2, c1 + 2))
    
    '3×3エリアが完成している場合は解法2不要のためExit
    If WorksheetFunction.CountBlank(BlockArea) = 0 Then Exit Sub

    For num = 1 To 9
    
        'BlockArea(3×3)にnumが存在しなければチェック開始
        If isExistNum(r1, c1, r1 + 2, c1 + 2) = False Then
            
            Dim cell As Range
            For Each cell In BlockArea '各セルに対して処理を繰り返す
            
                If cell.Value = "" Then
                
                    Dim check1 As Boolean, check2 As Boolean
                    check1 = isExistNum(cell.Row, 1, cell.Row, 9) '①行検索
                    check2 = isExistNum(1, cell.Column, 9, cell.Column) '②列検索
            
                    'numが【行】【列】どちらにも存在しなかったら
                    If check1 = False And check2 = False Then
            
                        Dim SetCnt As Long
                        SetCnt = SetCnt + 1 '代入可能セルの個数
                        
                        Dim y As Long, x As Long
                        y = cell.Row '現在地の【行】番号
                        x = cell.Column '現在地の【列】番号
                    
                    End If
            
                End If
            
            Next
            
            If SetCnt = 1 Then Call AnswerSet(y, x, num)
            
            SetCnt = 0 '次のnumに進むので、カウント変数を初期化
            
        End If
    
    Next num
    
End Sub

解法3モジュール

Option Explicit

Sub Solution3_Row()

    '解読対象の行が完成している場合は不要のためExit
    If WorksheetFunction.CountBlank(Range(Cells(r, 1), Cells(r, 9))) = 0 Then
        Exit Sub
    End If

    For num = 1 To 9
    
        '対象の【行】にnumが存在しなければチェック開始
        If isExistNum(r, 1, r, 9) = False Then

            Dim i As Long
            For i = 1 To 9 '1列目~9列目を順番にチェック
                
                If Cells(r, i).Value = "" Then
                
                    Dim c2 As Long
                    c2 = SearchBlockArea(i)
                
                    Dim check1 As Boolean, check2 As Boolean
                    check1 = isExistNum(1, i, 9, i) '列のチェック
                    check2 = isExistNum(r1, c2, r1 + 2, c2 + 2) 'BlockAreaのチェック
                    
                    'どちらにもnumが存在しなければ
                    If check1 = False And check2 = False Then
                        
                        Dim SetCnt As Long, x As Long
                        SetCnt = SetCnt + 1 '代入可能セルの個数
                        x = i '現在地の列番号
                        '行番号はrなので取得不要
                        
                    End If
                
                End If
                
            Next i
            
            '解答判定とセルへの書き込み
            If SetCnt = 1 Then Call AnswerSet(r, x, num)
            
            SetCnt = 0 '初期化

        End If

    Next num

End Sub

Sub Solution3_Col()

    '解読対象の列が完成している場合は不要のためExit
    If WorksheetFunction.CountBlank(Range(Cells(1, c), Cells(9, c))) = 0 Then
        Exit Sub
    End If

    For num = 1 To 9
    
        '対象の【列】にnumが存在しなければチェック開始
        If isExistNum(1, c, 9, c) = False Then

            Dim i As Long
            For i = 1 To 9 '1行目~9行目を順番にチェック
                
                If Cells(i, c).Value = "" Then
                
                    Dim r2 As Long
                    r2 = SearchBlockArea(i)
                    
                    Dim check1 As Boolean, check2 As Boolean
                    check1 = isExistNum(i, 1, i, 9) '行のチェック
                    check2 = isExistNum(r2, c1, r2 + 2, c1 + 2) 'BlockAreaのチェック
                    
                    'どちらにもnumが存在しなければ
                    If check1 = False And check2 = False Then
                        
                        Dim SetCnt As Long, y As Long
                        SetCnt = SetCnt + 1 '代入可能セルの個数
                        y = i '現在位置の行番号
                        '列番号はcなので取得不要
                    
                    End If
                
                End If
                
            Next i
            
            If SetCnt = 1 Then Call AnswerSet(y, c, num)
            
            SetCnt = 0 '初期化

        End If

    Next num

End Sub


最後までお読みいただきありがとうございました。

もう一度初回から読みたいという方はコチラからどうぞ!
【VBAナンプレ連載】

スポンサーリンク