エクセルVBAで数独を解く

エクセルVBAを使用して人が楽しみながら解く方法をプログラムしたものです

中級レベル?までは自動で答えが出ますが難度の高いものは自分で選択しないといけません。そこが数独を解く楽しみです??

例題としてナンプレ京を使わせて頂きました。有難うございました。

入力画面です。左側のエクセルシート(問題入力)に問題を手動で入力します。

問題入力シートの全マスをコピーして数独回答シートに貼り付けます

その後Ctrl+mで操作

この画面は空白セルに入力可能な数字の文字列を自動で表示した処です

回答画面です。プログラムは右側にコメントに有るように少しずつプログラムしてマクロ化しています。

youtubeにまだアップロードできないので途中経過は省略しています。

自分で解いてミス入力しないで答えにたどり着く感じです。

インチキですが回答後に答え合わせの為入力して登録した画面です

まだ、右手でマウスが早く操作出来ないので時間がかかっています。

操作手順などマクロ部分の説明

もう1問やってみました

ここからエクセルVBAのプログラムです

メインは一番最後になります

Dim jj As Integer   'セル縦位置
Dim ii As Integer   'セル横位置
Dim jm As Integer   'セル縦位置
Dim im As Integer   'セル横位置
Dim count As Integer   '置換回数

'セル範囲クリア
Sub sellclr()
  For j = 1 To 9 Step 1
    For i = 1 To 9 Step 1
        If VarType(Cells(j, i).Value) <> vbDouble Then
            Cells(j, i).Font.ColorIndex = 1
            Cells(j, i).Value = ""
       End If
    Next
  Next j
 
  ActiveCell.Font.Size = 16
  Cells(10, 9).Value = ""
  Cells(10, 10).Value = ""
  Cells(10, 11).Value = ""

End Sub

'空白セル検索
Sub sell_kensaku()
  For j = 1 To 9 Step 1
    For i = 1 To 9 Step 1
        If Cells(j, i).Value = "" Then
            Cells(j, i).Font.ColorIndex = 1
            Debug.Print "セル位置" + " j="; j; " i="; i
       End If
    Next
  Next j
End Sub

'セル範囲の横数字を連結して表示
Sub sum_mojiyoko()
  Dim moji As String
  Dim mojiretu As String
  mojiretu = "123456789"
 
  '横文字列
  For j = 1 To 9 Step 1
    For i = 1 To 9 Step 1
        If VarType(Cells(j, i).Value) = vbDouble Then
            moji = Cells(j, i).Value
            mojiretu = Replace(mojiretu, moji, "")
       End If
    Next
   
    mojiretu = "'" + mojiretu
   
    For i = 1 To 9 Step 1
        If VarType(Cells(j, i).Value) <> vbDouble Then
            Cells(j, i).Font.Size = 14
            Cells(j, i).Font.ColorIndex = 1
            Cells(j, i).Value = mojiretu
        End If
    Next i
    mojiretu = "123456789"
  Next j

End Sub

'セル範囲の縦数字を連結して表示
Sub sum_mojitate()
    Dim moji As String
    Dim mojiretu As String
    mojiretu = "123456789"
   
  Call sellclr
  '縦文字列
  For i = 1 To 9 Step 1
    For j = 1 To 9 Step 1
        If VarType(Cells(j, i).Value) = vbDouble Then
            moji = Cells(j, i).Value
   
            mojiretu = Replace(mojiretu, moji, "")
       End If
    Next
   
    mojiretu = "'" + mojiretu
   
    For j = 1 To 9 Step 1
        If VarType(Cells(j, i).Value) <> vbDouble Then
            Cells(j, i).Font.Size = 14
            Cells(j, i).Font.ColorIndex = 1
            Cells(j, i).Value = mojiretu
        End If
    Next
    mojiretu = "123456789"
  Next

End Sub

'セル範囲の縦横数字を連結して表示
Sub sum_mojitateyoko()
    Dim moji As String
    Dim mojiretu As String
    mojiretu = "123456789"
 
    Call sellclr
 
  '横文字列
    j = 1
    For i = 1 To 9 Step 1
        If VarType(Cells(j, i).Value) = vbDouble Then
            moji = Cells(j, i).Value
            mojiretu = Replace(mojiretu, moji, "")
       End If
    Next
   Debug.Print mojiretu
 
  '縦文字列
    i = 1
    For j = 1 To 9 Step 1
        If VarType(Cells(j, i).Value) = vbDouble Then
            moji = Cells(j, i).Value
            mojiretu = Replace(mojiretu, moji, "")
       End If
    Next
    mojiretu = "'" + mojiretu
    Debug.Print mojiretu
   
  '枡文字列
    j = 1: i = 1
   
    For j = 1 To 3 Step 1
      For i = 1 To 3 Step 1
        If VarType(Cells(j, i).Value) = vbDouble Then
            moji = Cells(j, i).Value
            mojiretu = Replace(mojiretu, moji, "")
       End If
     Next
    Next
    Debug.Print mojiretu

End Sub

'入力可能 数字文字列 検索設定
Sub set_suu()
    Dim moji As String
    Dim mojiretu As String
    mojiretu = "123456789"
 
  '横文字列
    For i = 1 To 9 Step 1
        If VarType(Cells(jj, i).Value) = vbDouble Then
            moji = Cells(jj, i).Value
            mojiretu = Replace(mojiretu, moji, "")
       End If
    Next
   Debug.Print "横数値 "; mojiretu
 
  '縦文字列
    For j = 1 To 9 Step 1
        If VarType(Cells(j, ii).Value) = vbDouble Then
            moji = Cells(j, ii).Value
            mojiretu = Replace(mojiretu, moji, "")
       End If
    Next
   
    mojiretu = "'" + mojiretu
    Debug.Print "縦数値 "; mojiretu
   
    Call zone(mojiretu, jj, ii)    '入力可能 枡内文字列 検索設定
   

End Sub

'入力可能 枡内文字列 検索設定
Sub zone(ByVal mojiretu As String, ByVal jj As Integer, ByVal ii As Integer)
   
    For j = jm To jm + 2 Step 1
      For i = im To im + 2 Step 1
        If VarType(Cells(j, i).Value) = vbDouble Then
              moji = Cells(j, i).Value
            mojiretu = Replace(mojiretu, moji, "")
       End If
     Next
    Next
    Debug.Print "枡文字"; mojiretu
   
    '結果表示
    If VarType(Cells(jj, ii).Value) <> vbDouble Then
        Cells(jj, ii).Font.Size = 18
        Cells(jj, ii).Font.ColorIndex = 1
        Cells(jj, ii).Value = mojiretu
    End If
    Debug.Print "結果表示"; mojiretu, jj, ii

End Sub

'枡文字列位置チェック

Sub zone_check(ByVal jj As Integer, ByVal ii As Integer)
   
    If 0 < jj And jj < 4 And 0 < ii And ii < 4 Then jm = 1: im = 1: GoTo Ext
    If 0 < jj And jj < 4 And 3 < ii And ii < 7 Then jm = 1: im = 4: GoTo Ext
    If 0 < jj And jj < 4 And 6 < ii And ii < 10 Then jm = 1: im = 7: GoTo Ext
   
    If 3 < jj And jj < 7 And 0 < ii And ii < 4 Then jm = 4: im = 1: GoTo Ext
    If 3 < jj And jj < 7 And 3 < ii And ii < 7 Then jm = 4: im = 4: GoTo Ext
    If 3 < jj And jj < 7 And 6 < ii And ii < 10 Then jm = 4: im = 7: GoTo Ext
   
    If 6 < jj And jj < 10 And 0 < ii And ii < 4 Then jm = 7: im = 1: GoTo Ext
    If 6 < jj And jj < 10 And 3 < ii And ii < 7 Then jm = 7: im = 4: GoTo Ext
    If 6 < jj And jj < 10 And 6 < ii And ii < 10 Then jm = 7: im = 7: GoTo Ext
Ext:
    Debug.Print "枡文字列位置チェック jj,ii,jm,im= "; jj, ii, jm, im

End Sub

'セル範囲の横数字を削除
Sub sakujo_yoko(ByVal jj As Integer, ByVal ii As Integer, ByVal moji As String)
   
    Debug.Print "横開始 jj ii moji="; jj, ii, moji
 
    For i = 1 To 9 Step 1
      If i <> ii Then
        cha = Cells(jj, i)
        If VarType(cha) = vbString Then
            mojiretu = Cells(jj, i).Value
            mojiretu = Replace(mojiretu, moji, "")
            Cells(jj, i).Value = "'" + mojiretu
            Debug.Print "i, 文字列   ="; i, mojiretu
        Else
            Debug.Print "i, 数字     ="; i, Cells(jj, i).Value
        End If
      Else
            Debug.Print "i, 削除文字 ="; i, Cells(jj, i).Value
      End If
    Next

End Sub

'セル範囲の縦数字を削除
Sub sakujo_tate(ByVal jj As Integer, ByVal ii As Integer, ByVal moji As String)
   
    Debug.Print "縦開始 jj ii moji="; jj, ii, moji
 
    For j = 1 To 9 Step 1
      If j <> jj Then
        If VarType(Cells(j, ii).Value) = vbString Then
            mojiretu = Cells(j, ii).Value
            mojiretu = Replace(mojiretu, moji, "")
            Cells(j, ii).Value = "'" + mojiretu
            Debug.Print "j, 文字列   ="; j, mojiretu
        Else
            Debug.Print "j, 数字     ="; j, Cells(j, ii).Value
        End If
      Else
            Debug.Print "j, 削除文字 ="; j, Cells(j, ii).Value
      End If
    Next

End Sub
 
'セル範囲の枡数字を削除
Sub sakujomasu(ByVal jj As Integer, ByVal ii As Integer, ByVal moji As String)
    Dim cha As String
    Row = ActiveCell.Row            '行 1,2,3-
    col = ActiveCell.Column         '列  A,B,C-
   
    Call zone_check(jj, ii)         '枡文字列位置チェック
   
    Debug.Print "枡開始 jm im moji="; jm, im, moji
   
    For j = jm To jm + 2 Step 1
        For i = im To im + 2 Step 1
            If VarType(Cells(j, i).Value) = vbString Then
                cha = Cells(j, i).Value
                If cha <> moji Then
                    mojiretu = Cells(j, i).Value
                    mojiretu = Replace(mojiretu, moji, "")
                    Cells(j, i).Value = "'" + mojiretu
                    Debug.Print "j,i 文字列   ="; j, i, mojiretu
                End If
            Else
                Debug.Print "j,i 数字     ="; j, i, Cells(j, i).Value
            End If
        Next
    Next

End Sub

'ActiveCell位置の値を行、列から削除
 Sub ActCel_sakujo()
   
    Row = ActiveCell.Row        '行 1,2,3-
    col = ActiveCell.Column     '列  A,B,C-
    Cell = ActiveCell.Value     '値
   
    If Cell <> "" And 0 < Val(Cell) And Val(Cell) < 10 Then
        ActiveCell.Value = Val(Cell)    'セル位置の文字を数値に変換 Cttr + a
        ActiveCell.Font.Size = 24
        ActiveCell.Font.ColorIndex = 10 '緑色の文字色
    Else
        Cells(10, 9).Value = "セル値異常"
        Stop
    End If
   
    Call sakujo_yoko(Row, col, Cell)    'セル範囲の横数字を削除
   
    Call sakujo_tate(Row, col, Cell)    'セル範囲の縦数字を削除
   
    Call sakujomasu(Row, col, Cell)     'セル範囲の枡数字を削除
   
 End Sub

'セル範囲の1〜9の数字を検索
Sub kensaku1()
    Dim cha As String
   
    Cells(10, 10).Value = ""
    Debug.Print "枡開始 jm im moji="; jm, im, moji
    Cells(10, 5).Value = "列,行,値"
    Cells(10, 6).Value = "-"
    Cells(10, 7).Value = "-"
    Cells(10, 8).Value = "-"
    Cells(10, 9).Value = "-"
   
    For j = 1 To 9 Step 1
        For i = 1 To 9 Step 1
            If VarType(Cells(j, i).Value) = vbString Then
                cha = Cells(j, i).Value                 'セルの文字取り込み
                If Len(cha) = 1 Then                    'セルは1文字
                    Cells(10, 6).Value = j
                    Cells(10, 7).Value = i
                    Cells(10, 8).Value = cha
                    Cells(j, i).Activate                'セル選択
                    Debug.Print "j,i 数字   ="; j, i, cha
                   
                    Call ActCel_sakujo                  'ActiveCell位置の値を行、列から削除
                   
                    Cells(10, 9).Value = "縦横枡削除"
                    count = count + 1                   '削除回数
                    Cells(10, 1).Value = count
                    Exit Sub
                End If
            End If
        Next
    Next
    Cells(10, 9).Value = " 検索終了"

End Sub

'セル範囲の1〜9の数字を検索 Ctrl+z
'見つけた数字のセル位置の横、縦、枡、の範囲の数字を削除
'見つからなく成るまで繰り返し
Sub Del()
    Cells(10, 9).Font.ColorIndex = 1 '黒色の文字色
   
    Do
        Call kensaku1
       
        For j = 1 To 9
            For i = 1 To 9
                If Cells(j, i) = "" Then
                    Cells(10, 6) = i
                    Cells(10, 7) = j
                    Cells(10, 8) = Cells(j, i)
                    Cells(10, 9) = "セル値異常!"
                    Cells(10, 9).Font.ColorIndex = 3 '赤色の文字色
                    End
                End If
            Next
        Next
               
        Application.Wait Now + TimeValue("00:00:01")   '1秒待ち時間
   
    Loop While Cells(10, 6).Value <> "-"
    Cells(10, 9).Value = " 連続削除終了"
   
    Call tandokusuX                     '行の単独数を探す
        count = count + 1               '削除回数
        Cells(10, 1).Value = count
   
    If Cells(10, 8).Value <> "-" Then
        Exit Sub
    End If
   
    Call tandokusuY                     '列の単独数を探す
        count = count + 1               '削除回数
        Cells(10, 1).Value = count

End Sub

'行の単独数を探す               'Ctrl + x
Sub tandokusuX()

    mojiretu = "123456789"
    Row = ActiveCell.Row        '行 1,2,3-
    col = ActiveCell.Column     '列  A,B,C-
    Row = 1
    col = 1
   
    Dim ch(9) As Integer
   
    Debug.Print " "
    Debug.Print "行単独数字 開始"
    Cells(10, 9).Value = "行単独探す"
               
    Cells(10, 9).Value = ""
    For j = Row To 9 Step 1
        For p = 1 To 9 Step 1
            ch(p) = 0
        Next
        For i = col To 9 Step 1
            cha = Cells(j, i).Value
            If VarType(cha) = vbString Then
                For p = 1 To Len(cha)
                    c = Mid$(cha, p, 1)
                    Select Case c
                        Case "1"
                            ch(1) = ch(1) + 1
                        Case "2"
                            ch(2) = ch(2) + 1
                        Case "3"
                            ch(3) = ch(3) + 1
                        Case "4"
                            ch(4) = ch(4) + 1
                        Case "5"
                            ch(5) = ch(5) + 1
                        Case "6"
                            ch(6) = ch(6) + 1
                        Case "7"
                            ch(7) = ch(7) + 1
                        Case "8"
                            ch(8) = ch(8) + 1
                        Case "9"
                            ch(9) = ch(9) + 1
                    End Select
                Next
            End If
        Next
        For p = 1 To 9
            Debug.Print "数字 j,p "; j, p, ch(p)
            If ch(p) = 1 Then
                Cells(10, 5) = "行"     'Row
                Cells(10, 6) = j
                Cells(10, 7) = "数値"
                Cells(10, 8) = p
                Cells(10, 9).Value = "行単独数字"
               
                For i = 1 To 9
                    cha = Cells(j, i)
                    If InStr(cha, CStr(p)) <> 0 Then
                        Cells(11, 5) = "行数文字列"
                        Cells(11, 7) = cha
                        Cells(j, i) = "'" + CStr(p)
                        Cells(j, i).Font.ColorIndex = 5 '青色の文字色
                        Call Del                'セル範囲の1〜9の数字を検索
                        Exit Sub
                    End If
                Next
           
            Else
'                Cells(10, 10).Value = ""
            End If
        Next
    Next
    Cells(10, 10).Value = ""
    Cells(10, 9).Value = "行単独数無し"
    Debug.Print "行単独数字 終"

End Sub

'列の単独数を探す
Sub tandokusuY()                'Ctrl + y

    mojiretu = "123456789"
    Row = ActiveCell.Row        '行 1,2,3-
    col = ActiveCell.Column     '列  A,B,C-
    Row = 1
    col = 1
   
    Dim ch(9) As Integer
   
    Debug.Print " "
    Debug.Print "縦単独数字 開始"
    Cells(10, 9).Value = "縦単独探す"
               
    Cells(10, 9).Value = ""
    For i = col To 9 Step 1
        For p = 1 To 9 Step 1
            ch(p) = 0
        Next
        For j = Row To 9 Step 1
            cha = Cells(j, i).Value
            If VarType(cha) = vbString Then
                For p = 1 To Len(cha)
                    c = Mid$(cha, p, 1)
                    Select Case c
                        Case "1"
                            ch(1) = ch(1) + 1
                        Case "2"
                            ch(2) = ch(2) + 1
                        Case "3"
                            ch(3) = ch(3) + 1
                        Case "4"
                            ch(4) = ch(4) + 1
                        Case "5"
                            ch(5) = ch(5) + 1
                        Case "6"
                            ch(6) = ch(6) + 1
                        Case "7"
                            ch(7) = ch(7) + 1
                        Case "8"
                            ch(8) = ch(8) + 1
                        Case "9"
                            ch(9) = ch(9) + 1
                    End Select
                Next
            End If
        Next
        For p = 1 To 9
            Debug.Print "数字 i,p "; i, p, ch(p)
            If ch(p) = 1 Then
                Cells(10, 5) = "列"
                Cells(10, 6) = Mid$("ABCDEFGHI", i, 1)
                'Cells(10, 6) = i
                Cells(10, 7) = "数値"
                Cells(10, 8) = p
                Cells(10, 9).Value = "列単独数字"
               
                For j = 1 To 9
                    cha = Cells(j, i)
                    If InStr(cha, CStr(p)) <> 0 Then
                        Cells(11, 5) = "列数文字列"
                        Cells(11, 7) = cha
                        Cells(j, i) = "'" + CStr(p)
                        Cells(j, i).Font.ColorIndex = 5 '青色の文字色
                        Call Del            'セル範囲の1〜9の数字を検索
                        Exit Sub
                    End If
                Next
           
            Else
'                Cells(10, 10).Value = ""
            End If
        Next
    Next
    Cells(10, 10).Value = ""
    Cells(10, 9).Value = "列単独数無し"
    Debug.Print "列単独数字 終"

End Sub

'OK終了チェック Ctrl + e
Sub ok()
 
  Cells(10, 9).Value = "チェック"
  For j = 1 To 9 Step 1
    For i = 1 To 9 Step 1
        cha = Cells(j, i)
        If 0 < cha And cha < 10 Then
            '
        Else
            Exit Sub
       End If
    Next
  Next j
 
  Cells(j, i).Font.ColorIndex = 32
  Cells(10, 9).Value = "やったね!"

End Sub

'=====================================================================
'   MAIN sudoku_15.vba  2017/02/21 回答数81
'
'   空白セルに入力可能な数字の文字列を設定マクロ CTL + m Main() 最初に実行
'   ActiveCell位置の値を行,列,枡から削除 マクロ CTL + a  ActCel_sakujo()
'   自動削除可能な数字1文字のセルを検索 マクロ CTL + s  kensaku1()
'   行列範囲の複数文字列から単独文字を探すマクロ CTL + c
'   横単独文字を探して連続削除その後行列の単独数を探す CTL + x tandokusuX()
'   縦単独文字を探して連続削除その後行列の単独数を探す CTL + y tandokusuY()
'   セル位置の横、縦、枡、の範囲の数字を削除 マクロ Ctrl + z Del()
'   回答チェックを追加 CTL + e
'   横単文字列のセル位置を探して単独数に置き換え 青色
'   単独数(青色)が見つかったらDelをCALL
'   空白セルになったらセル異常で停止
'
'   セルが空白になるバグを修正
'   自動削除不可能な数字はセルを選択して編集する
'=====================================================================
Sub Main()
 
    Debug.Print "開始"
    count = 0
    Cells(10, 1).Value = count

    Call sellclr                    'セル範囲クリア
   
    For jj = 1 To 9 Step 1
        For ii = 1 To 9 Step 1
            Call zone_check(jj, ii) '枡文字列位置チェック
            Call set_suu            '入力可能数字設定
        Next
    Next

End Sub

'------------------------------------------------------------------------
'   Application.Wait Now + TimeValue("00:00:01")    '1秒待ち時間

プログラムはここまでです

 

後記

突然の病気で倒れ入院中にプログラムしたものです

入院当初はマウスも使えず苦労しました。クリックボタンをクリックすると微かにマウスが動いてしまいクリック入力が出来ません

でした。今でもダブルクリックは苦手です。リハビリをかねてノートパソコンで入力、編集しています。

視床下部の出血で身動き出来ませんでした。夜でしたが早く救急車で運ばれて救急のお医者さんが脳神経の先生でしたので処置が

良かったおかげで軽い後遺症でした。右手と右足の失調が現在も残っています。プログラムなどをする思考部分に障害がないか

自分で試しに作ったプログラムです。取り合えず良さそうな気もしますがどうでしょうか?