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

筆者がポンコツすぎて上手くアルゴリズムが書けないので
上級問題はまだ解けません

次記事→

［ここにURLを書く！］

←前記事

---

ざっくり説明

中級程度までならナンプレを解いてくれます

コード

SolveNumberPlace

Option Explicit
Option Base 1
Public npSquareQue As Range
Public npSquareAns As Range

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)
    Set npSquareQue = Range(npSquareQueUL, npSquareQueUL.Offset(8, 8))
    Set npSquareAns = Range(npSquareAnsUL, npSquareAnsUL.Offset(8, 8))

    Dim row As Long
    Dim col As Long
    Dim npSquare As Variant
    Dim npSqToCompareBfr As String
    Dim npSqToCompareAft As String
    Dim npSqToCompareBfrTop As String
    Dim npSqToCompareAftTop As String
    Dim target As String
    npSquare = npSquareQue
    
    Call FillWithDummyValues(npSquare)

    Do
        npSqToCompareBfrTop = joinAllElements(npSquare)

        Do
            npSqToCompareBfr = joinAllElements(npSquare)
            For row = 1 To 9
                For col = 1 To 9
                    target = npSquare(row, col)
                    If Len(target) = 1 Then
                        Call RemoveDuplicates(npSquare, row, col)
                    End If
                Next
            Next
            npSqToCompareAft = joinAllElements(npSquare)
        Loop Until npSqToCompareBfr = npSqToCompareAft

        Do
            npSqToCompareBfr = joinAllElements(npSquare)
            For row = 1 To 9 Step 3
                For col = 1 To 9 Step 3
                    Call FindUnique(npSquare, row, col)
                Next
            Next
            npSqToCompareAft = joinAllElements(npSquare)
        Loop Until npSqToCompareBfr = npSqToCompareAft

        Do
            npSqToCompareBfr = joinAllElements(npSquare)
            For row = 1 To 9 Step 3
                For col = 1 To 9 Step 3
                    Call RemoveDuplicates2DigitsPairBlock(npSquare, row, col)
                Next
            Next
            npSqToCompareAft = joinAllElements(npSquare)
        Loop Until npSqToCompareBfr = npSqToCompareAft

        Do
            npSqToCompareBfr = joinAllElements(npSquare)
            For row = 1 To 9
                For col = 1 To 9
                    If row = 1 Or col = 1 Then
                        Call RemoveDuplicates2DigitsPairVandH(npSquare, row, col)
                    End If
                Next
            Next
            npSqToCompareAft = joinAllElements(npSquare)
        Loop Until npSqToCompareBfr = npSqToCompareAft

        npSqToCompareAftTop = joinAllElements(npSquare)
    Loop Until npSqToCompareBfrTop = npSqToCompareAftTop

    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 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 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 RemoveDuplicates2DigitsPairBlock(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 blkRowUL As Long
    Dim blkColUL As Long
    blkRowUL = blkRow * 3 - 2
    blkColUL = blkCol * 3 - 2
    
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim l As Long
    Dim n As Long
    Dim d As Long
    Dim r As Long
    Dim c As Long

    n = 1
    Dim blkArr(1 To 9) As String
    For i = blkRowUL To blkRowUL + 2
        For j = blkColUL To blkColUL + 2
            blkArr(n) = npSquare(i, j)
            n = n + 1
        Next
    Next

    Dim clue As String
    Dim clue2Digits As String
    For i = 1 To 9
        For j = i + 1 To 9
            If blkArr(i) = blkArr(j) And Len(blkArr(i)) = 2 And i < j Then
                r = blkRowUL + Int((i - 1) / 3)
                c = blkColUL + (j - 1) Mod 3
                clue2Digits = blkArr(i)

                For d = 1 To 2
                    clue = Mid(clue2Digits, d, 1)

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

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

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

                If i Mod 3 = j Mod 3 Then
                    For d = 1 To 2
                        For k = 1 To 9
                            Dim targetRowV As Long
                            Dim targetColV As Long
                            targetRowV = k
                            targetColV = blkColUL + (i - 1) Mod 3
                            clue2Digits = blkArr(i)
                            clue = Mid(clue2Digits, d, 1)
                            
                            Dim targetV As String
                            targetV = npSquare(targetRowV, targetColV)
                    
                            If targetV <> clue2Digits Then
                                npSquare(targetRowV, targetColV) = Replace(targetV, clue, "")
                            End If
                        Next
                    Next
                End If

                If Int((i - 1) / 3) = Int((j - 1) / 3) Then
                    For d = 1 To 2
                        For k = 1 To 9
                            Dim targetRowH As Long
                            Dim targetColH As Long
                            targetRowH = blkRowUL + Int((i - 1) / 3)
                            targetColH = k
                            clue2Digits = blkArr(i)
                            clue = Mid(clue2Digits, d, 1)

                            Dim targetH As String
                            targetH = npSquare(targetRowH, targetColH)

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

Sub RemoveDuplicates2DigitsPairVandH(ByRef npSquare As Variant, ByVal clueRow As Long, ByVal clueCol As Long)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim d As Long
    Dim clue As String
    Dim clue2Digits As String

    If clueRow = 1 Then
        Dim VArr(1 To 9) As String
        For i = 1 To 9
            VArr(i) = npSquare(i, clueCol)
        Next

        For i = 1 To 9
            For j = i + 1 To 9
                If VArr(i) = VArr(j) And Len(VArr(i)) = 2 And i < j Then
                    For d = 1 To 2
                        For k = 1 To 9
                            clue2Digits = VArr(i)
                            clue = Mid(clue2Digits, d, 1)
                            Dim targetV As String
                            targetV = npSquare(k, clueCol)
    
                            If targetV <> clue2Digits Then
                                npSquare(k, clueCol) = Replace(targetV, clue, "")
                            End If
                        Next
                    Next
                End If
            Next
        Next
    End If

    If clueCol = 1 Then
        Dim HArr(1 To 9) As String
        For i = 1 To 9
            HArr(i) = npSquare(clueRow, i)
        Next

        For i = 1 To 9
            For j = i + 1 To 9
                If HArr(i) = HArr(j) And Len(HArr(i)) = 2 And i < j Then
                    For d = 1 To 2
                        For k = 1 To 9
                            clue2Digits = HArr(i)
                            clue = Mid(clue2Digits, d, 1)
                            
                            Dim targetH As String
                            targetH = npSquare(clueRow, i)

                            If targetH <> clue2Digits Then
                                npSquare(clueRow, k) = Replace(targetH, clue, "")
                            End If
                        Next
                    Next
                End If
            Next
        Next
    End If
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
                    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
    checkLength = joinAllElements(npSquare)

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

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

    joinAllElements = result
End Function

使用方法

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

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

仕様等

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

注意点

上級問題はまだ解けません