[Excel VBA] ナンプレを解く(未完成2)

完成したと思ってましたが
まだ完全ではありませんでした！

次記事→

←前記事

---

ざっくり説明

ナンプレを解いてくれます
解いたような素振をしてくれます

コード

SolveNumberPlace

Option Explicit
Option Base 1

Sub SolveNumberPlace()
'================================
'用途　　：ナンプレの解答を求める
'--------------------------------
'入力　　：npSquareQueULに解きたい
'　　　　　方陣の左上セルをRange型で渡す
'出力　　：npSquareAnsULに解答を入力したい
'　　　　　9×9の範囲の左上セルをRange型で渡す
'================================
    Dim npSquareQueUL As Range
    Dim npSquareAnsUL As Range
    Set npSquareQueUL = ThisWorkbook.Sheets(1).Cells(1, 1)
    Set npSquareAnsUL = ThisWorkbook.Sheets(1).Cells(11, 1)

    Dim npSquareQue As Range
    Dim npSquareAns As Range
    Set npSquareQue = Range(npSquareQueUL, npSquareQueUL.Offset(8, 8))
    Set npSquareAns = Range(npSquareAnsUL, npSquareAnsUL.Offset(8, 8))

    Dim completionStatus As Boolean
    Dim stopCounter As Long
    Dim npSquare As Variant
    Dim Row As Long
    Dim col As Long
    npSquare = npSquareQue
    
    Call FillWithDummyValues(npSquare)

    Do Until completionStatus = True
        For Row = 1 To 9
            For col = 1 To 9
                Dim target As String
                target = npSquare(Row, col)
                If Len(target) = 1 Then
                    Call RemoveDuplicates(npSquare, Row, col)
                End If
                
                Dim blkRowBR As Long: blkRowBR = Row Mod 3
                Dim blkColBR As Long: blkColBR = col Mod 3
                If (blkRowBR + blkColBR) = 0 Then
                    Call FindUnique(npSquare, Row, col)
                End If
            Next
        Next
        completionStatus = isComplete(npSquare)

        stopCounter = stopCounter + 1
        If stopCounter > 100 Then Exit Do
    Loop

    npSquareAns = npSquare

End Sub

Sub RemoveDuplicates(ByRef npSquare As Variant, ByVal clueRow As Long, ByVal clueCol As Long)
    Dim blkRow As Long
    Dim blkCol As Long
    blkRow = Int((clueRow - 1) / 3) + 1
    blkCol = Int((clueCol - 1) / 3) + 1

    Dim i As Long
    Dim j As Long
    Dim clue As String
    clue = npSquare(clueRow, clueCol)

    For i = 1 To 3
        For j = 1 To 3
            Dim targetRowB As Long
            Dim targetColB As Long
            targetRowB = (blkRow - 1) * 3 + i
            targetColB = (blkCol - 1) * 3 + j

            Dim targetB As String
            targetB = npSquare(targetRowB, targetColB)

            If targetB <> clue Then
                npSquare(targetRowB, targetColB) = Replace(targetB, clue, "")
            End If
        Next
    Next

    For i = 1 To 9
        Dim targetRowV As Long
        Dim targetColV As Long
        targetRowV = i
        targetColV = clueCol
        
        Dim targetV As String
        targetV = npSquare(targetRowV, targetColV)

        If targetV <> clue Then
            npSquare(targetRowV, targetColV) = Replace(targetV, clue, "")
        End If
    Next

    For i = 1 To 9
        Dim targetRowH As Long
        Dim targetColH As Long
        targetRowH = clueRow
        targetColH = i
        
        Dim targetH As String
        targetH = npSquare(targetRowH, targetColH)

        If targetH <> clue Then
            npSquare(targetRowH, targetColH) = Replace(targetH, clue, "")
        End If
    Next
End Sub

Sub FindUnique(ByRef npSquare As Variant, ByVal blkRow As Long, ByVal blkCol As Long)
    blkRow = Int((blkRow - 1) / 3) + 1
    blkCol = Int((blkCol - 1) / 3) + 1
    
    Dim blkRowUL As Long
    Dim blkColUL As Long
    blkRowUL = blkRow * 3 - 2
    blkColUL = blkCol * 3 - 2

    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim listNums As String

    For i = blkRowUL To blkRowUL + 2
        For j = blkColUL To blkColUL + 2
            If Len(npSquare(i, j)) <> 1 Then
                listNums = listNums & CStr(npSquare(i, j))
            End If
        Next
    Next

    For n = 1 To 9
        If Len(listNums) - Len(Replace(listNums, n, "")) = 1 Then
            For i = blkRowUL To blkRowUL + 2
                For j = blkColUL To blkColUL + 2
                    If InStr(npSquare(i, j), n) <> 0 Then
                        npSquare(i, j) = n
                        Call RemoveDuplicates(npSquare, i, j)
                    End If
                Next
            Next
        End If
    Next
End Sub

Sub FillWithDummyValues(ByRef npSquare As Variant)
    Dim i As Long
    Dim j As Long

    For i = 1 To 9
        For j = 1 To 9
            If IsEmpty(npSquare(i, j)) Then
                npSquare(i, j) = "123456789"
            End If
        Next
    Next
End Sub

Function isComplete(ByVal npSquare As Variant) As Boolean
    Dim checkLength As String
    Dim i As Long
    For i = 1 To 9
        Dim j As Long
        For j = 1 To 9
            checkLength = CStr(checkLength) + CStr(npSquare(i, j))
        Next
    Next

    If Len(checkLength) = 81 Then
        isComplete = True
    Else
        isComplete = False
    End If
End Function

使用方法

A1セルからI9セルの9×9の範囲に解きたいナンプレの
判明している数字を入力してマクロを実行すると、
A11セルからI19セルに答えが表示されます。

問題の入力元の9×9と、出力先の9×9は
npSquareQueULに入力元 左上セルを、
npSquareAnsULに出力先 左上セルを設定すれば変更可能です。

仕様等

内部では、空白セルに123456789という文字列を入力したあと
確定している数字から消していくという手順で特定しています。

注意点

解けない問題はヒントが足りていないのか、はたまた
アルゴリズムが不十分なのか。

その他

推理小説において、筆者より頭の良い犯人／探偵の姿は
画くことができないという話がある…！