数独（再挑戦）⑥ 一つしかないなら、それで確定 - Infomentのブログ～Excel VBA奮闘記～

昨日は計算過程を一巡する毎に答えを張り付けて、途中経過を見える化してみた。
infoment.hatenablog.com

今日は、現時点で解ききれない問題について考えてみる。
f:id:Infoment:20191205224253p:plain

探してみると、こちらの問題を解き切れなかった。
f:id:Infoment:20191205224418p:plain

それでは、この中身を見てみよう。
f:id:Infoment:20191205224512p:plain

すると、ここに突破口があった。この行には、「6」が一つしかなかったのだ。
f:id:Infoment:20191205224930p:plain

ただ、可能性として「1」が残っていたため、「6」を確定できずにいたようだ。
f:id:Infoment:20191205225104p:plain

ならば「6」が一つしかないことを理由としてその他の数字を０にできれば、このマスは「6」で確定する。

以上のことから、このような作戦が成立する。

上から順に一行ずつ、１つしか存在しない数を探す。
もしあれば、その場所を特定する。
特定したマスを、その数で確定させる。

試しに、行についてのみ作成してみよう。

Private Sub UniqueExistence()
    Dim r As Long, r2 As Long
    Dim c As Long, c2 As Long
    Dim arr As Variant
    Dim i As Long
        For r = 1 To 27
            ' １行スライスして、新たな配列を作成する。
            arr = WorksheetFunction.Index(TempArray, r, 0)
            ' この配列に１～９の値が幾つ含まれるか確認する。
            For i = 1 To 9
                ' 調査した値が一つしかない場合、確定可能。
                If ArrayCountIF(arr, i) = 1 Then
                    ' 一つしかなかった値の列番号を取得。
                    ' ※完全一致で取得しない場合、正しい結果にならない。要注意。
                    c = WorksheetFunction.Match(i, arr, 0)
                    ' ２７×２７の行列を、９×９に換算する。
                    r2 = WorksheetFunction.RoundUp(r / 3, 0)
                    c2 = WorksheetFunction.RoundUp(c / 3, 0)
                    ' 上記で求めたセルの値が未確定の場合、確定させる。
                    If FixedNumber(r2, c2) = 0 Then
                        FixedCell r2, c2, i
                    End If
                End If
            Next
        Next
End Sub

上記を、SetAnswerに追加する。

Public Sub SetAnswer()
    Dim r As Long
    Dim c As Long
    Dim n As Long
    Dim SumAll As Long
    Dim counter As Long
    
        ' 編集の有無を確認するために、予め配列の合計値を求めておく。
        ' ※何らかの編集があれば、１以上の値が０に置き換わり、合計も変わる。
        SumAll = WorksheetFunction.Sum(TempArray)
        
        ' 編集の前後で合計値の差が無くなるまで、つまり何も置き換わらなくなる
        ' まで繰り返す。
        Do
            For r = 1 To 9
                For c = 1 To 9
                    n = FixedNumber(r, c)
                    If n <> 0 Then
                        DeleteNumber r, c, n
                    End If
                Next
            Next
            
            UniqueExistence '←　今回、ここに追加。
            
            ' 一巡したところで解答取得。
            GetAnswerArray
            
            ' 解答貼り付け範囲に、解答を格納した配列を貼り付け。
            DestinationRange = AnswerArray
            
            ' １秒待つ。
            Application.Wait Now + TimeValue("0:00:01")
            
            If SumAll = WorksheetFunction.Sum(TempArray) Then
                Exit Do
            Else
                SumAll = WorksheetFunction.Sum(TempArray)
            End If
            
            ' 念のため、仮の措置として、１００回繰り返したらループを抜ける。
            counter = counter + 1
            If counter >= 100 Then Exit Do
        Loop
End Sub