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

未完成のコードです
解けない問題もあります
解ける問題もあります

次記事→

---

初級問題で正答率が7割ぐらいで
答えを導ける問題と導けない問題があります。

あくまでこれは叩き台で、思いのままにコードを書いてるので
可読性とか無視なのでアルゴリズムが安定したら清書します。

解けなかった問題のどこで不整合出たか紐解きながら修正していきます。
それにしてもネストが深いですね。

SolveNumberPlace

Option Explicit
Option Base 1

Sub SolveSolveNumberPlace()
'================================
'用途　　：ナンプレの解答を求める
'--------------------------------
'入力　　：Sheets(1)のA1～I9に
'　　　　　問題の方陣を入力
'出力　　：Sheets(1)のA11～I19に
'　　　　　解答の方陣を出力
'================================
    Dim WB As Workbook
    Dim WS As Worksheet
    Set WB = ThisWorkbook
    Set WS = WB.Sheets(1)
    
    Dim sudokuSquare As Variant
    sudokuSquare = WS.Range(WS.Cells(1, 1), WS.Cells(1, 1).Offset(8, 8))

    Dim completionStatus As Boolean
    Dim stopCounter As Long
    Do Until completionStatus = True
        stopCounter = stopCounter + 1
        If stopCounter > 300 Then Exit Do
        sudokuSquare = ConvertEmptyToDummyValue(sudokuSquare)
        sudokuSquare = CheckCruciform(sudokuSquare)
        sudokuSquare = CheckBlock(sudokuSquare)
        sudokuSquare = CheckCruciformUnique(sudokuSquare)
        sudokuSquare = CheckBlockUnique(sudokuSquare)
        sudokuSquare = StringToDouble(sudokuSquare)
        completionStatus = isComplete(sudokuSquare)
        WS.Range(WS.Cells(11, 1), WS.Cells(11, 1).Offset(8, 8)) = sudokuSquare
    Loop

    WS.Range(WS.Cells(11, 1), WS.Cells(11, 1).Offset(8, 8)) = sudokuSquare
End Sub

Function ConvertEmptyToDummyValue(ByVal sudokuSquare As Variant) As Variant
    Dim i As Long
    For i = 1 To 9
        Dim j As Long
        For j = 1 To 9
            If IsEmpty(sudokuSquare(i, j)) Or Len(sudokuSquare(i, j)) <> 1 Then
                sudokuSquare(i, j) = "123456789"
            End If
        Next
    Next

    ConvertEmptyToDummyValue = sudokuSquare
End Function

Function CheckCruciform(ByVal sudokuSquare As Variant) As Variant
    Dim i As Long
    For i = 1 To 9
        Dim j As Long
        For j = 1 To 9
            Dim k As Long
            For k = 1 To 9
                If i <> k And _
                    Len(sudokuSquare(k, j)) = 1 And _
                    InStr(sudokuSquare(i, j), sudokuSquare(k, j)) <> 0 Then
                    sudokuSquare(i, j) = Replace(sudokuSquare(i, j), sudokuSquare(k, j), "")
                End If
                If j <> k And _
                    Len(sudokuSquare(i, k)) = 1 And _
                    InStr(sudokuSquare(i, j), sudokuSquare(i, k)) <> 0 Then
                    sudokuSquare(i, j) = Replace(sudokuSquare(i, j), sudokuSquare(i, k), "")
                End If
            Next
            If Len(sudokuSquare(i, j)) = 1 Then sudokuSquare(i, j) = CLng(sudokuSquare(i, j))
        Next
    Next
    CheckCruciform = sudokuSquare
End Function

Function CheckBlock(ByVal sudokuSquare As Variant) As Variant
    Dim x As Long
    For x = 1 To 3
        Dim y As Long
        For y = 1 To 3
            Dim block(1 To 9) As Variant
            Dim i As Long
            For i = 1 To 3
                Dim j As Long
                For j = 1 To 3
                    block((i - 1) * 3 + j) = sudokuSquare(i + 3 * (x - 1), j + 3 * (y - 1))
                Next
            Next

            Dim k As Long
            For k = 1 To 3
                Dim l As Long
                For l = 1 To 3
                    Dim z As Long
                    For z = 1 To 9
                        If Len(block(z)) = 1 And _
                            Not block(z) = sudokuSquare(k + 3 * (x - 1), l + 3 * (y - 1)) And _
                            InStr(sudokuSquare(k + 3 * (x - 1), l + 3 * (y - 1)), block(z)) <> 0 Then
                            sudokuSquare(k + 3 * (x - 1), l + 3 * (y - 1)) = Replace(sudokuSquare(k + 3 * (x - 1), l + 3 * (y - 1)), block(z), "")
                        End If
                    Next
                Next
            Next
        Next
    Next
    CheckBlock = sudokuSquare
End Function

Function CheckCruciformUnique(ByVal sudokuSquare As Variant) As Variant
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim l As Long
    Dim m As Long

    For i = 1 To 9
        Dim numCountH As String: numCountH = ""
        For j = 1 To 9
            If Len(sudokuSquare(i, j)) <> 1 Then
                For k = 1 To Len(sudokuSquare(i, j))
                    numCountH = numCountH & Mid(sudokuSquare(i, j), k, 1)
                Next
            End If

            If j = 9 Then
                For l = 1 To 9
                    If Len(numCountH) - Len(Replace(numCountH, l, "")) = 1 Then
                        For m = 1 To 9
                            If InStr(sudokuSquare(i, m), l) <> 0 Then
                                sudokuSquare(i, m) = l
                                sudokuSquare = RemoveDuplicatesInBlock(sudokuSquare, i, m, l)
                                CheckCruciformUnique = sudokuSquare
                                Exit Function
                            End If
                        Next
                    End If
                Next
            End If
        Next
    Next

    For i = 1 To 9
        Dim numCountV As String: numCountV = ""
        For j = 1 To 9
            If Len(sudokuSquare(j, i)) <> 1 Then
                For k = 1 To Len(sudokuSquare(j, i))
                    numCountV = numCountV & Mid(sudokuSquare(j, i), k, 1)
                Next
            End If
            If j = 9 Then
                For l = 1 To 9
                    If Len(numCountV) - Len(Replace(numCountV, l, "")) = 1 Then
                        For m = 1 To 9
                            If InStr(sudokuSquare(m, i), l) <> 0 Then
                                sudokuSquare(m, i) = l
                                sudokuSquare = RemoveDuplicatesInBlock(sudokuSquare, m, i, l)
                                CheckCruciformUnique = sudokuSquare
                                Exit Function
                            End If
                        Next
                    End If
                Next
            End If
        Next
    Next
    CheckCruciformUnique = sudokuSquare
End Function

Function CheckBlockUnique(ByVal sudokuSquare As Variant) As Variant
    Dim x As Long
    Dim y As Long
    Dim r As Long
    Dim c As Long
    Dim k As Long
    Dim l As Long

    For x = 1 To 3
        For y = 1 To 3
            Dim numCount As String: numCount = ""
            For r = 1 To 3
                For c = 1 To 3
                    If Len(sudokuSquare(r + 3 * (x - 1), c + 3 * (y - 1))) <> 1 Then
                        For k = 1 To Len(sudokuSquare(r + 3 * (x - 1), c + 3 * (y - 1)))
                            numCount = numCount & Mid(sudokuSquare(r + 3 * (x - 1), c + 3 * (y - 1)), k, 1)
                        Next
                    End If
                Next
            Next

            For l = 1 To 9
                If Len(numCount) - Len(Replace(numCount, l, "")) = 1 Then
                    For r = 1 To 3
                        For c = 1 To 3
                            If InStr(sudokuSquare(r + 3 * (x - 1), c + 3 * (y - 1)), l) <> 0 Then
                                sudokuSquare(r + 3 * (x - 1), c + 3 * (y - 1)) = l
                                sudokuSquare = RemoveDuplicatesInBlock(sudokuSquare, r + 3 * (x - 1), c + 3 * (y - 1), l)
                                CheckBlockUnique = sudokuSquare
                                Exit Function
                            End If
                        Next
                    Next
                End If
            Next
        Next
    Next
    CheckBlockUnique = sudokuSquare
End Function

Function RemoveDuplicatesInBlock(ByVal sudokuSquare As Variant, ByVal row As Long, ByVal col As Long, ByVal targetNum As Long) As Variant
    Dim firstRow As Long
    Dim firstCol As Long
    firstRow = GetFirstNumber(row)
    firstCol = GetFirstNumber(col)

    Dim r As Long
    For r = firstRow To (firstRow + 2)
        Dim c As Long
        For c = firstCol To (firstCol + 2)
            If Len(sudokuSquare(r, c)) <> 1 Then
                sudokuSquare(r, c) = Replace(sudokuSquare(r, c), targetNum, "")
            End If
        Next
    Next

    RemoveDuplicatesInBlock = sudokuSquare
End Function

Function GetFirstNumber(ByVal target As Long) As Long
    Select Case target
        Case 1 To 3
            GetFirstNumber = 1
        Case 4 To 6
            GetFirstNumber = 4
        Case 7 To 9
            GetFirstNumber = 7
        Case Else
            GetFirstNumber = 0 ' 使われない想定
    End Select
End Function


Function StringToDouble(ByVal sudokuSquare As Variant) As Variant
    Dim i As Long
    For i = 1 To 9
        Dim j As Long
        For j = 1 To 9
            If Len(sudokuSquare(i, j)) = 1 Then
                sudokuSquare(i, j) = CDbl(sudokuSquare(i, j))
            End If
        Next
    Next

    StringToDouble = sudokuSquare
End Function

Function isComplete(ByVal sudokuSquare 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(sudokuSquare(i, j))
        Next
    Next

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