Excel VBA セル操作

Excel VBA のトップに戻る
Excel VBA 目次

索引

数独

　数独とは（ウィキペディア）
https://ja.wikipedia.org/wiki/%E6%95%B0%E7%8B%AC

　このマクロは、数独の問題を自動作成したり、既存の問題を自動解答するものです。
　既に、数独の問題を解答するアプリは多数公開されています。
ただこれらのアプリの多くは、人手による解法とは異なり、コンピュータの特長を利用した探査(≒再帰)を使って解決しています。
　例えば、下記で VBA をダウンロードできます。
https://excel-ubara.com/excelvba5/EXCELVBA231_3.html

　ここで紹介するマクロは、人が解答する過程をそのままプログラミングしたものです。
このため、ステップ表示を on にして使うと、数独の解き方のヒントになることを目的としています。
　このマクロを作ろうとした背景は、新聞で「数独の問題、どうやって作るの？」という記事を読んだことです。
そこに「必ず解ける配置」を人が頭で考えるよ、という記述があり、たっぷり1日かかった、と書かれていたので、マクロで作ってみようと思いました。
　私は、このマクロを作るのに、連休 3日間費やしてしまいました。(^^ゞ

参考サイト：問題を入力すると、解答プロセスを表示してくれます。
http://nanpre.adg5.com/nanpre_make.php
http://algorithm.main.jp/Puzzle/Sudoku/3-Input.php

このマクロをダウンロードできます。→SuDokuVBA14.xls

'作成：2020/07/25：渡辺真
'更新：2020/07/30：双子(NAKED PAIR) 、トリプル、Xウイングによる候補除外を追加
'クリエイティブ・コモンズ「表示-非営利-継承 表示-非営利-継承 Attribution-NonCommercial-ShareAlike」

Option Explicit
Option Base 1

   Dim 配列(9, 9) As Integer '行、列
   Dim 配列マスク(9, 9) As String '行、列
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 候補配列(9, 9, 2) As Variant '行、列、候補数、候補文字列
   Dim 仮置きカウンタ As Integer
   Dim 仮置き可能数 As Integer
   Dim 仮置き配列(100) As String '仮置きカウンタ、行、列、値
   Dim 盤更新 As Boolean
   Dim 効果 As Boolean
   Dim ステップ表示 As Boolean
   Dim 候補配列変更 As Boolean
   
   
'**************************************************************************
Sub 数独数表生成()
'**************************************************************************

   Dim 行 As Integer
   Dim 列 As Integer
   Dim 数 As Integer
   Dim 重複 As Boolean
   Dim ブロック横 As Integer
   Dim ブロック縦 As Integer
   Dim カウンタ As Integer
   Dim 完成 As Boolean
   Dim 重複内容 As String
   Dim トライ数 As Integer
   
   完成 = False
   トライ数 = 0
   
   開始日時 = Now                ' 開始時刻を変数に格納します。
      
   Do While 完成 = False
      トライ数 = トライ数 + 1
   
      ThisWorkbook.Worksheets("sheet1").Range("A1:I9").ClearContents
      ThisWorkbook.Worksheets("sheet1").Range("A1:I9").Interior.ColorIndex = xlColorIndexNone
      Erase 配列
      重複内容 = ""

      For 数 = 1 To 9
         For 列 = 1 To 9
         
            重複 = True
            カウンタ = 0
            
            If 可能性(数, 列) = True Then
         
               Do While 重複 = True And カウンタ <= 500
                  カウンタ = カウンタ + 1
                  
                  Do
                     行 = 乱数(1, 9)
'                     Stop
'                     Debug.Print 行, 列
                  Loop While 配列(行, 列) > 0
                  
                  重複 = 行内重複(行, 数)
                  
                  If 重複 = False Then
   '                  Stop
                     Select Case 列
                        Case Is <= 3
                           ブロック横 = 0
                        Case Is >= 7
                           ブロック横 = 2
                        Case Else
                           ブロック横 = 1
                     End Select
                     
                     Select Case 行
                        Case Is <= 3
                           ブロック縦 = 0
                        Case Is >= 7
                           ブロック縦 = 2
                        Case Else
                           ブロック縦 = 1
                     End Select
                     重複 = ブロック重複(ブロック縦, ブロック横, 数)
                     If 重複 = True Then
                        重複内容 = "ブロック重複"
                     End If
                  Else
'                     重複内容 = "行内重複"
                  End If

               Loop
               
'               *************
               If カウンタ >= 500 Then
               
                  For 行 = 1 To 9
                     If 配列(行, 列) = 0 Then
            '            Stop
                        重複 = 行内重複(行, 数)
                        
                        If 重複 = False Then
         '                  Stop
                           Select Case 列
                              Case Is <= 3
                                 ブロック横 = 0
                              Case Is >= 7
                                 ブロック横 = 2
                              Case Else
                                 ブロック横 = 1
                           End Select
                           
                           Select Case 行
                              Case Is <= 3
                                 ブロック縦 = 0
                              Case Is >= 7
                                 ブロック縦 = 2
                              Case Else
                                 ブロック縦 = 1
                           End Select
                           重複 = ブロック重複(ブロック縦, ブロック横, 数)
                           If 重複 = True Then
                              重複内容 = "ブロック重複"
                           End If
                           
                        Else
'                           重複内容 = "行内重複"
                        End If
                     End If
                  Next 行
               End If
               
'               *************
               If 重複 = False Then
                  ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = 数
                  配列(行, 列) = 数
               Else
'                  MsgBox "数 = " & 数 & " 列 = " & 列 & "  " & 重複内容 & " カウンタ = " & カウンタ
'                  Stop
                  Exit For
               End If
            Else
'               MsgBox "可能性無し " & 可能性(数, 列) & " 数 = " & 数 & " 列 = " & 列 & " カウンタ = " & カウンタ
'               Stop
               Exit For
            End If
         Next 列
         
         If 列 < 10 Then
            Exit For
         End If
   
      Next 数
      
      If 列 = 10 Then
         完成 = True
      End If
   
   Loop
   
   終了日時 = Now
   
   MsgBox "数独数表 完成！   トライ数 = " & トライ数 & vbNewLine _
   & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub


'**************************************************************************
Sub 数独解決()
'**************************************************************************
   Dim 行 As Integer
   Dim 列 As Integer
   Dim 解決 As Boolean

   
   開始日時 = Now                ' 開始時刻を変数に格納します。
   ステップ表示 = ThisWorkbook.Worksheets("sheet1").Range("J9").Value
   
   '空白部分が 0 で表示されている場合、空白にする
   For 行 = 1 To 9
      For 列 = 1 To 9
         If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = "0" Then
            ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = ""
         End If
      Next 列
   Next 行
   
   解決 = False
   Call 数独解決本体(解決)
   
   終了日時 = Now
   ThisWorkbook.Worksheets("sheet1").Range("J19:S29").Value = ""
   
   If 解決 = True Then
      MsgBox "数独解決！" & vbNewLine _
      & "処理時間は、" _
      & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
   Else
      MsgBox "解決できませんでした！" & vbNewLine _
      & "処理時間は、" _
      & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
   End If

End Sub


'**************************************************************************
Private Sub 数独解決本体(解決 As Boolean)
'**************************************************************************

   Dim 行 As Integer
   Dim 列 As Integer
   Dim 対象行 As Integer
   Dim 対象列 As Integer
   Dim 値 As Integer
   
   仮置きカウンタ = 0
   
最初から:

   '★★★初級作戦★★★
   '行、列、ブロック毎に、空白1ヶ所を調べて、数を入れて行く
   Do
      Do
         効果 = False
         For 行 = 1 To 9
            For 列 = 1 To 9
               If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = "" Then
                  Call 候補絞り込み(行, 列)
               End If
            Next 列
         Next 行
      
      Loop While 効果 = True
   
      '結果確認
      解決 = True
      For 行 = 1 To 9
         For 列 = 1 To 9
            If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = "" Then
               解決 = False
               Exit For
            End If
         Next 列
      Next 行
      
      '★★★中級作戦★★★
      '候補から特異値を決める
      If 解決 = False Then
         効果 = False
         '固有候補を見つける
         Call 固有候補抽出
      End If
      
   Loop While 効果 = True

   '結果確認
   解決 = True
   For 行 = 1 To 9
      For 列 = 1 To 9
         If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = "" Then
            解決 = False
            Exit For
         End If
      Next 列
   Next 行
   
'   Stop
   
   '★★★上級作戦★★★
   '仮置き作戦を使う：候補配列で、候補が2つのものに限り、一つずつ試していく
   '候補配列書き出し
   ThisWorkbook.Worksheets("sheet1").Range("K20").Value = "仮置き作戦を使う"
   ThisWorkbook.Worksheets("sheet1").Range("O20").Value = ""
   For 行 = 1 To 9
      For 列 = 1 To 9
         ThisWorkbook.Worksheets("sheet1").Range("K21").Cells(行, 列).Value = 候補配列(行, 列, 2)
      Next 列
   Next 行
'   Stop
   
   If 解決 = False Then
      If 仮置きカウンタ = 0 Then

'        候補配列(9, 9, 2) 行、列、候補数、候補文字列、K21
'        仮置き配列(100) As String '仮置きカウンタ、行、列、値 (計3文字)を作成
         Erase 仮置き配列
         For 行 = 1 To 9
            For 列 = 1 To 9
               If 候補配列(行, 列, 1) = 2 Then
                  仮置きカウンタ = 仮置きカウンタ + 1
                  仮置き配列(仮置きカウンタ) = Trim(Str(行)) & Trim(Str(列)) & Left(Trim(Str(候補配列(行, 列, 2))), 1)
                  仮置きカウンタ = 仮置きカウンタ + 1
                  仮置き配列(仮置きカウンタ) = Trim(Str(行)) & Trim(Str(列)) & Right(Trim(Str(候補配列(行, 列, 2))), 1)
'                  Stop
               End If
            Next 列
         Next 行
         仮置き可能数 = 仮置きカウンタ
         仮置きカウンタ = 1
         
         '数独の現在の状態を、A31に保存
         ThisWorkbook.Worksheets("sheet1").Range("A1:I9").Copy Range("A31")
'         Stop
         '候補を仮置き
         対象行 = Val(Left(仮置き配列(1), 1))
         対象列 = Val(Mid(仮置き配列(1), 2, 1))
         値 = Val(Right(仮置き配列(1), 1))
         ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(対象行, 対象列).Value = 値
         ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(対象行, 対象列).Interior.ColorIndex = 6  '黄色
'         Stop
         If ステップ表示 = True Then
            MsgBox "仮置き： " & 対象行 & "　" & 対象列 & "　値= " & 値
         End If
'         Stop
         GoTo 最初から
      ElseIf 仮置きカウンタ < 仮置き可能数 Then
         '仮置き前の状態に戻す
         ThisWorkbook.Worksheets("sheet1").Range("A31:I39").Copy Range("A1")
         '候補を仮置き
         仮置きカウンタ = 仮置きカウンタ + 1
         対象行 = Val(Left(仮置き配列(仮置きカウンタ), 1))
         対象列 = Val(Mid(仮置き配列(仮置きカウンタ), 2, 1))
         値 = Val(Right(仮置き配列(仮置きカウンタ), 1))
         ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(対象行, 対象列).Value = 値
         ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(対象行, 対象列).Interior.ColorIndex = 6  '黄色
'         Stop
         If ステップ表示 = True Then
            MsgBox "仮置き： " & 対象行 & "　" & 対象列 & "　値= " & 値
         End If
         GoTo 最初から
      End If
   End If
   
   '結果確認
   解決 = True
   For 行 = 1 To 9
      For 列 = 1 To 9
         If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = "" Then
            解決 = False
            Exit For
         End If
      Next 列
   Next 行
   
End Sub


'**************************************************************************
Private Sub 固有候補抽出()
'**************************************************************************

   Dim 行 As Integer
   Dim 列 As Integer
   Dim ブロック横 As Integer
   Dim ブロック縦 As Integer
   Dim カウンタ As Integer
   Dim カウント As Integer
   Dim 抽出用配列(9, 9) As Integer
   Dim 文字目 As Integer
   Dim 抽出用位置 As Integer
   Dim 出力行 As Integer
   Dim 出力列 As Integer
   
'      Dim 候補配列(9, 9, 2) As Variant '行、列、候補数、候補文字列

最初から:
   Do
      Do
         Do
            Do
               Call 候補抽出
               '候補が1つだけならば、その候補で確定
               盤更新 = False
               For 行 = 1 To 9
                  For 列 = 1 To 9
                     If 候補配列(行, 列, 1) = 1 Then
                        ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = 候補配列(行, 列, 2)
                        ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Interior.ColorIndex = 4   '黄緑
                        盤更新 = True
                        候補配列変更 = False
            '           Stop
                     End If
                  Next 列
               Next 行
            Loop While 盤更新 = True
               
            For 行 = 1 To 9
               Erase 抽出用配列
               '1行毎に、各セルの候補を横(行)方向に展開して、候補がユニークな列を見つける
               For 列 = 1 To 9
                  For カウンタ = 1 To 9
                     For 文字目 = 1 To 候補配列(行, 列, 1)
                        If カウンタ = Mid(候補配列(行, 列, 2), 文字目, 1) Then
                           抽出用配列(列, カウンタ) = 1
                        End If
                     Next 文字目
                  Next カウンタ
               Next 列
               ThisWorkbook.Worksheets("sheet1").Range("A21").Resize(9, 9).Value = 抽出用配列
               
               盤更新 = False
               For カウンタ = 1 To 9
                  カウント = 0
                  For 列 = 1 To 9
                     カウント = カウント + 抽出用配列(列, カウンタ)
                  Next 列
                  If カウント = 1 Then '候補列確定
                     For 列 = 1 To 9
                        If 抽出用配列(列, カウンタ) = 1 Then
            '               Stop
                           ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = カウンタ
                           ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Interior.ColorIndex = 4   '黄緑
                           盤更新 = True
                           候補配列変更 = False
         '                  Stop
                           If ステップ表示 = True Then
                              MsgBox "横(行)方向 " & 行 & "　" & 列 & "　値= " & カウンタ
                           End If
                        End If
                     Next 列
                  End If
         '         Stop
               Next カウンタ
            Next 行
         Loop While 盤更新 = True
         
      
         For 列 = 1 To 9
            Erase 抽出用配列
            For 行 = 1 To 9
               For カウンタ = 1 To 9
                  For 文字目 = 1 To 候補配列(行, 列, 1)
                     If カウンタ = Mid(候補配列(行, 列, 2), 文字目, 1) Then
                        抽出用配列(行, カウンタ) = 1
                     End If
                  Next 文字目
               Next カウンタ
            Next 行
            ThisWorkbook.Worksheets("sheet1").Range("A21").Resize(9, 9).Value = 抽出用配列
            
      '      Stop
      
            盤更新 = False
            For カウンタ = 1 To 9
               カウント = 0
               For 行 = 1 To 9
                  カウント = カウント + 抽出用配列(行, カウンタ)
               Next 行
               If カウント = 1 Then '候補確定
                  For 行 = 1 To 9
                     If 抽出用配列(行, カウンタ) = 1 Then
         '               Stop
                        ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = カウンタ
                        ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Interior.ColorIndex = 4   '黄緑
                        盤更新 = True
                        候補配列変更 = False
      '                  Stop
                        If ステップ表示 = True Then
                           MsgBox "縦(列)方向 " & 行 & " " & 列 & " 値= " & カウンタ
                        End If
                     End If
                  Next 行
               End If
            Next カウンタ
         Next 列
      Loop While 盤更新 = True
      
      
      For ブロック縦 = 0 To 2
         For ブロック横 = 0 To 2
   '
            Erase 抽出用配列
            抽出用位置 = 0
            For 行 = 1 To 3
               For 列 = 1 To 3
                  抽出用位置 = 抽出用位置 + 1
                  For カウンタ = 1 To 9
                     For 文字目 = 1 To 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1)
                        If カウンタ = Mid(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2), 文字目, 1) Then
                           抽出用配列(抽出用位置, カウンタ) = 1
                        End If
                     Next 文字目
                  Next カウンタ
               Next 列
            Next 行
            ThisWorkbook.Worksheets("sheet1").Range("A21").Resize(9, 9).Value = 抽出用配列
   
            盤更新 = False
            For カウンタ = 1 To 9
               カウント = 0
               For 抽出用位置 = 1 To 9
                  カウント = カウント + 抽出用配列(抽出用位置, カウンタ)
               Next 抽出用位置
   '            Stop
               If カウント = 1 Then '候補確定
                  For 抽出用位置 = 1 To 9
                     If 抽出用配列(抽出用位置, カウンタ) = 1 Then
      '                  Stop
                        出力行 = ブロック縦 * 3 + (抽出用位置 + 2) \ 3
                        出力列 = ブロック横 * 3 + (抽出用位置 - 1) Mod 3 + 1
                        ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(出力行, 出力列).Value = カウンタ
                        ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(出力行, 出力列).Interior.ColorIndex = 4   '黄緑
                        盤更新 = True
                        候補配列変更 = False
   '                     Stop
                        If ステップ表示 = True Then
                           MsgBox "ブロック方向 " & 出力行 & " " & 出力列 & " 値= " & カウンタ
                        End If
   '                     If (出力行 = 6 And 出力列 = 6) Or (出力行 = 8 And 出力列 = 6) Then Stop
                     End If
                  Next 抽出用位置
               End If
            Next カウンタ
   '         Stop
         Next ブロック横
      Next ブロック縦
   Loop While 盤更新 = True
   
   Call 候補抽出
   
   If 候補配列変更 = True Then GoTo 最初から
   
End Sub


'**************************************************************************
Private Sub 候補絞り込み(対象行 As Integer, 対象列 As Integer)
'**************************************************************************

   Dim 対象外配列(9) As Integer
   Dim 行 As Integer
   Dim 列 As Integer
   Dim ブロック横 As Integer
   Dim ブロック縦 As Integer
   Dim カウンタ As Integer
   Dim カウント As Integer
   
   Erase 対象外配列
   
   For 行 = 1 To 9
      If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 対象列).Value <> "" Then
         対象外配列(ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 対象列).Value) = 1
      End If
   Next 行
   
   For 列 = 1 To 9
      If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(対象行, 列).Value <> "" Then
         対象外配列(ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(対象行, 列).Value) = 1
      End If
   Next 列
   
'      ブロック
   Select Case 対象列
      Case Is <= 3
         ブロック横 = 0
      Case Is >= 7
         ブロック横 = 2
      Case Else
         ブロック横 = 1
   End Select
   
   Select Case 対象行
      Case Is <= 3
         ブロック縦 = 0
      Case Is >= 7
         ブロック縦 = 2
      Case Else
         ブロック縦 = 1
   End Select

   For 行 = 1 To 3
      For 列 = 1 To 3
         If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(ブロック縦 * 3 + 行, ブロック横 * 3 + 列).Value <> "" Then
            対象外配列(ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(ブロック縦 * 3 + 行, ブロック横 * 3 + 列).Value) = 1
         End If
      Next 列
   Next 行
   
   カウント = 0
   For カウンタ = 1 To 9
      カウント = カウント + 対象外配列(カウンタ)
   Next カウンタ
   
   If カウント = 8 Then
      For カウンタ = 1 To 9
         If 対象外配列(カウンタ) = 0 Then
            ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(対象行, 対象列).Value = カウンタ
            ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(対象行, 対象列).Interior.ColorIndex = 4   '黄緑
            盤更新 = True
            候補配列変更 = False
'            Stop
            Exit For
         End If
      Next カウンタ
   End If

End Sub


'**************************************************************************
Private Sub 候補抽出()
'**************************************************************************

   Dim 対象行 As Integer
   Dim 対象列 As Integer
   Dim 行 As Integer
   Dim 列 As Integer
   Dim ブロック横 As Integer
   Dim ブロック縦 As Integer
   Dim カウンタ As Integer
   Dim カウント As Integer
   Dim 文字数 As Integer

   Erase 候補配列
   
   For 対象行 = 1 To 9
      For 対象列 = 1 To 9
         If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(対象行, 対象列).Value = "" Then
   
            候補配列(対象行, 対象列, 1) = 9 '行、列、候補数、候補文字列
            候補配列(対象行, 対象列, 2) = "123456789" '行、列、候補数、候補文字列
            
            For 行 = 1 To 9
               If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 対象列).Value <> "" Then
         '      Stop
                  文字数 = Len(候補配列(対象行, 対象列, 2))
                  候補配列(対象行, 対象列, 2) _
                  = Replace(候補配列(対象行, 対象列, 2), _
                  Trim(Str(ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 対象列).Value)), "")
                  If 文字数 > Len(候補配列(対象行, 対象列, 2)) Then
                     候補配列(対象行, 対象列, 1) = 候補配列(対象行, 対象列, 1) - 1
                  End If
               End If
            Next 行
            
            For 列 = 1 To 9
               If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(対象行, 列).Value <> "" Then
                  文字数 = Len(候補配列(対象行, 対象列, 2))
                  候補配列(対象行, 対象列, 2) _
                  = Replace(候補配列(対象行, 対象列, 2), _
                  Trim(Str(ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(対象行, 列).Value)), "")
                  If 文字数 > Len(候補配列(対象行, 対象列, 2)) Then
                     候補配列(対象行, 対象列, 1) = 候補配列(対象行, 対象列, 1) - 1
                  End If
               End If
            Next 列
            
         '      ブロック
            Select Case 対象列
               Case Is <= 3
                  ブロック横 = 0
               Case Is >= 7
                  ブロック横 = 2
               Case Else
                  ブロック横 = 1
            End Select
            
            Select Case 対象行
               Case Is <= 3
                  ブロック縦 = 0
               Case Is >= 7
                  ブロック縦 = 2
               Case Else
                  ブロック縦 = 1
            End Select
         
            For 行 = 1 To 3
               For 列 = 1 To 3
                  If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(ブロック縦 * 3 + 行, ブロック横 * 3 + 列).Value <> "" Then
                     文字数 = Len(候補配列(対象行, 対象列, 2))
                     候補配列(対象行, 対象列, 2) _
                     = Replace(候補配列(対象行, 対象列, 2), Trim(Str(Range("A1").Cells(ブロック縦 * 3 + 行, ブロック横 * 3 + 列).Value)), "")
                     If 文字数 > Len(候補配列(対象行, 対象列, 2)) Then
                        候補配列(対象行, 対象列, 1) = 候補配列(対象行, 対象列, 1) - 1
                     End If
                  End If
               Next 列
            Next 行
         End If
      Next 対象列
   Next 対象行
   
'   候補配列書き出し
   ThisWorkbook.Worksheets("sheet1").Range("K20").Value = "候補配列"
   ThisWorkbook.Worksheets("sheet1").Range("O20").Value = ""
   For 行 = 1 To 9
      For 列 = 1 To 9
         ThisWorkbook.Worksheets("sheet1").Range("K21").Cells(行, 列).Value = 候補配列(行, 列, 2)
      Next 列
   Next 行
'   Stop

   Call 双子除外
   Call トリプル除外
   Call 双子除外
   Call Xウイング
   ThisWorkbook.Worksheets("sheet1").Range("J19").Value = "候補配列変更"
   ThisWorkbook.Worksheets("sheet1").Range("J20").Value = 候補配列変更
'   Stop
   
End Sub

'**************************************************************************
Private Sub Xウイング()
'**************************************************************************
'同一の候補数字がヨコ軸（またはタテ軸）で見たときに２つずつ存在する列が２列あり、
'その４つのマスを結ぶ線が長方形（または正方形）になることが「X-ウイング」の条件。
'共に同一のブロックに属するときは「X-wing」は使えません。
   Dim 候補 As Integer
   Dim 候補数 As Integer
   Dim Xウイング候補配列(9, 9) As Integer  '行、列、候補の値：Xウイングになりうる対象候補の配列
   Dim Xウイング候補行(9) As String  '候補行で、どの列に該当値があるかの場所を示す。例：000100001、Xウイングの判定用
   Dim Xウイング候補列(9) As String  '候補列で、どの行に該当値があるかの場所を示す。例：000100001、Xウイングの判定用
   Dim Xウイング行配列(2) As Integer 'Xウイングの該当行
   Dim Xウイング列配列(2) As Integer 'Xウイングの該当列
   Dim Xウイング成立 As Boolean
   Dim 行 As Integer
   Dim 列 As Integer
   Dim カウンタ As Integer
   Dim 起点カウンタ As Integer
   Dim Xウイングカウンタ As Integer
   
   For 候補 = 1 To 9
      '*****行方向******************************************************

      Erase Xウイング候補配列
      Erase Xウイング候補行
      効果 = False
                           
      For 行 = 1 To 9
         候補数 = 0
         For 列 = 1 To 9
            If InStr(候補配列(行, 列, 2), Trim(Str(候補))) > 0 Then 'セルの候補に対象候補が有れば取りあえず抽出
               Xウイング候補配列(行, 列) = 候補
               候補数 = 候補数 + 1
            End If
         Next 列
         If 候補数 = 2 Then   '候補数がペアになっているもののみ抽出
            For 列 = 1 To 9
               If Xウイング候補配列(行, 列) > 0 Then
                  Xウイング候補行(行) = Xウイング候補行(行) & "1"
               Else
                  Xウイング候補行(行) = Xウイング候補行(行) & "0"
               End If
            Next 列
         Else   '候補数 <> 2 Then   'ペアになっていない候補数は除外する
            For 列 = 1 To 9
               Xウイング候補配列(行, 列) = 0
            Next 列
            Xウイング候補行(行) = "000000000"
         End If
      Next 行
      
'      Xウイング判定

      Erase Xウイング列配列
      Erase Xウイング行配列
      
      'Xウイングの存在確認
      Xウイング成立 = False
      
      For 起点カウンタ = 1 To 9 - 1
         If 個数(Xウイング候補行(起点カウンタ)) > 0 Then
            For カウンタ = 起点カウンタ + 1 To 9
               If Xウイング候補行(起点カウンタ) = Xウイング候補行(カウンタ) Then '候補位置のペア発生→Xウイング
                  Xウイング成立 = True
                  Xウイングカウンタ = 0
                  For 列 = 1 To 9
                     If Mid(Xウイング候補行(起点カウンタ), 列, 1) = 1 Then
                        Xウイングカウンタ = Xウイングカウンタ + 1
                        Xウイング列配列(Xウイングカウンタ) = 列
                     End If
                  Next 列
                  Xウイング行配列(1) = 起点カウンタ
                  Xウイング行配列(2) = カウンタ
                  Exit For
               End If
            Next カウンタ
         End If
      Next 起点カウンタ
      
      If Xウイング成立 = True Then 'Xウイングが存在した
         ThisWorkbook.Worksheets("Sheet1").Range("A41").Resize(9, 9).Value = Xウイング候補配列
'         Stop
      End If
      
      If Xウイング行配列(2) > 0 And Xウイング列配列(2) > 0 Then
         For 行 = 1 To 9
            If 行 <> Xウイング行配列(1) And 行 <> Xウイング行配列(2) Then
               For カウンタ = 1 To 2
                  候補配列(行, Xウイング列配列(カウンタ), 2) = Replace(候補配列(行, Xウイング列配列(カウンタ), 2), Trim(Str(候補)), "")
                  If 候補配列(行, Xウイング列配列(カウンタ), 1) > Len(候補配列(行, Xウイング列配列(カウンタ), 2)) Then
                     候補配列(行, Xウイング列配列(カウンタ), 1) = Len(候補配列(行, Xウイング列配列(カウンタ), 2))
                     効果 = True
                     候補配列変更 = True
                  End If
               Next カウンタ
            End If
         Next 行
      End If
      
      If 効果 = True Then
      '   候補配列書き出し
         ThisWorkbook.Worksheets("sheet1").Range("K20").Value = "Xウイング：縦方向"
         ThisWorkbook.Worksheets("sheet1").Range("O20").Value = "該当数= " & 候補 & " 効果= " & 効果
         For 行 = 1 To 9
            For 列 = 1 To 9
               ThisWorkbook.Worksheets("sheet1").Range("K21").Cells(行, 列).Value = 候補配列(行, 列, 2)
            Next 列
         Next 行
'         Stop
      End If

      
      '*****列方向******************************************************
      Erase Xウイング候補配列
      Erase Xウイング候補列
      効果 = False
      
      For 列 = 1 To 9
         候補数 = 0
         For 行 = 1 To 9
            If InStr(候補配列(行, 列, 2), Trim(Str(候補))) > 0 Then
               Xウイング候補配列(行, 列) = 候補
               候補数 = 候補数 + 1
            End If
         Next 行
         If 候補数 = 2 Then   '候補数がペアになっているもののみ抽出
            For 行 = 1 To 9
               If Xウイング候補配列(行, 列) > 0 Then
                  Xウイング候補列(列) = Xウイング候補列(列) & "1"
               Else
                  Xウイング候補列(列) = Xウイング候補列(列) & "0"
               End If
            Next 行
         Else   '候補数 <> 2 Then   'ペアになっていない候補数は除外する
            For 行 = 1 To 9
               Xウイング候補配列(行, 列) = 0
            Next 行
            Xウイング候補列(列) = "000000000"
         End If
      Next 列
      
'      Xウイング判定

      Erase Xウイング列配列
      Erase Xウイング行配列
      
      'Xウイングの存在確認
      Xウイング成立 = False
      
      For 起点カウンタ = 1 To 9 - 1
         If 個数(Xウイング候補列(起点カウンタ)) > 0 Then
            For カウンタ = 起点カウンタ + 1 To 9
               If Xウイング候補列(起点カウンタ) = Xウイング候補列(カウンタ) Then '候補位置のペア発生→Xウイング
                  Xウイング成立 = True
                  Xウイングカウンタ = 0
                  For 行 = 1 To 9
                     If Mid(Xウイング候補列(起点カウンタ), 行, 1) = 1 Then
                        Xウイングカウンタ = Xウイングカウンタ + 1
                        Xウイング行配列(Xウイングカウンタ) = 行
                     End If
                  Next 行
                  Xウイング列配列(1) = 起点カウンタ
                  Xウイング列配列(2) = カウンタ
                  Exit For
               End If
            Next カウンタ
         End If
      Next 起点カウンタ

      If Xウイング成立 = True Then 'Xウイングが存在した
         ThisWorkbook.Worksheets("Sheet1").Range("A41").Resize(9, 9).Value = Xウイング候補配列
'         Stop
         
      End If
      
      If Xウイング列配列(2) > 0 And Xウイング行配列(2) > 0 Then
         For 列 = 1 To 9
            If 列 <> Xウイング列配列(1) And 列 <> Xウイング列配列(2) Then
               For カウンタ = 1 To 2
                  候補配列(Xウイング行配列(カウンタ), 列, 2) = Replace(候補配列(Xウイング行配列(カウンタ), 列, 2), Trim(Str(候補)), "")
                  If 候補配列(Xウイング行配列(カウンタ), 列, 1) > Len(候補配列(Xウイング行配列(カウンタ), 列, 2)) Then
                     候補配列(Xウイング行配列(カウンタ), 列, 1) = Len(候補配列(Xウイング行配列(カウンタ), 列, 2))
                     効果 = True
                     候補配列変更 = True
                  End If
               Next カウンタ
            End If
         Next 列
      End If
      
      If 効果 = True Then
      '   候補配列書き出し
         ThisWorkbook.Worksheets("sheet1").Range("K20").Value = "Xウイング：横方向"
         ThisWorkbook.Worksheets("sheet1").Range("O20").Value = "該当数= " & 候補 & " 効果= " & 効果
         For 行 = 1 To 9
            For 列 = 1 To 9
               ThisWorkbook.Worksheets("sheet1").Range("K21").Cells(行, 列).Value = 候補配列(行, 列, 2)
            Next 列
         Next 行
'         Stop
      End If
      
   Next 候補

End Sub


'**************************************************************************
Private Sub 双子除外()
'**************************************************************************
   Dim 双子候補1 As String
   Dim 双子候補2 As String
   Dim 双子文字列 As String
   Dim 双子有 As Boolean
   Dim 行 As Integer
   Dim 列 As Integer
   Dim ブロック横 As Integer
   Dim ブロック縦 As Integer

'  候補配列(9, 9, 2) As Variant '行、列、候補数、候補文字列

   効果 = False
   
   For 行 = 1 To 9
      '1行毎に、各セルの候補で、二つの同一候補の有無を確認開して、候補がユニークな列を見つける
      双子文字列 = ""
      双子候補1 = ""
      双子候補2 = ""
      双子有 = False
      For 列 = 1 To 9
         If 候補配列(行, 列, 1) = 2 Then
'            Stop
            If 双子候補1 = "" Then
               双子候補1 = 候補配列(行, 列, 2)
            ElseIf 双子候補1 = 候補配列(行, 列, 2) Then
               双子文字列 = 双子候補1
               双子有 = True
               Exit For
            ElseIf 双子候補2 = 候補配列(行, 列, 2) Then
               双子文字列 = 双子候補2
               双子有 = True
               Exit For
            Else
               双子候補2 = 候補配列(行, 列, 2)
            End If
         End If
      Next 列
      
      If 双子有 = True Then
         For 列 = 1 To 9
            If 候補配列(行, 列, 2) <> 双子文字列 Then
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Left(双子文字列, 1), "")
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Right(双子文字列, 1), "")
               If 候補配列(行, 列, 1) > Len(候補配列(行, 列, 2)) Then
                  候補配列(行, 列, 1) = Len(候補配列(行, 列, 2))
                  効果 = True
                  候補配列変更 = True
               End If
            End If
         Next 列
      End If
   Next 行
   
   For 列 = 1 To 9
      双子文字列 = ""
      双子候補1 = ""
      双子候補2 = ""
      双子有 = False
      For 行 = 1 To 9

         If 候補配列(行, 列, 1) = 2 Then
'            Stop
            If 双子候補1 = "" Then
               双子候補1 = 候補配列(行, 列, 2)
            ElseIf 双子候補1 = 候補配列(行, 列, 2) Then
               双子文字列 = 双子候補1
               双子有 = True
               Exit For
            ElseIf 双子候補2 = 候補配列(行, 列, 2) Then
               双子文字列 = 双子候補2
               双子有 = True
               Exit For
            Else
               双子候補2 = 候補配列(行, 列, 2)
            End If
         End If
      Next 行

      If 双子有 = True Then
         For 行 = 1 To 9
            If 候補配列(行, 列, 2) <> 双子文字列 Then
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Left(双子文字列, 1), "")
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Right(双子文字列, 1), "")
               If 候補配列(行, 列, 1) > Len(候補配列(行, 列, 2)) Then
                  候補配列(行, 列, 1) = Len(候補配列(行, 列, 2))
                  効果 = True
               End If
            End If
         Next 行
      End If
   Next 列

   For ブロック縦 = 0 To 2
      For ブロック横 = 0 To 2
         双子文字列 = ""
         双子候補1 = ""
         双子候補2 = ""
         双子有 = False
         For 行 = 1 To 3
            For 列 = 1 To 3
               If 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) = 2 Then
'                  Stop
                  If 双子候補1 = "" Then
                     双子候補1 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2)
                  ElseIf 双子候補1 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) Then
                     双子文字列 = 双子候補1
                     双子有 = True
                     Exit For
                  ElseIf 双子候補2 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) Then
                     双子文字列 = 双子候補2
                     双子有 = True
                     Exit For
                  Else
                     双子候補2 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2)
                  End If
               End If
            Next 列
         Next 行
         
         If 双子有 = True Then
            For 行 = 1 To 3
               For 列 = 1 To 3
               If 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) <> 双子文字列 Then
                  候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) _
                  = Replace(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2), Left(双子文字列, 1), "")
                  候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) _
                  = Replace(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2), Right(双子文字列, 1), "")
                  If 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) _
                  > Len(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2)) Then
                     候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) _
                     = Len(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2))
                     効果 = True
                  End If
               End If
               Next 列
            Next 行
         End If
      Next ブロック横
   Next ブロック縦
   
'   候補配列書き出し
   ThisWorkbook.Worksheets("sheet1").Range("K20").Value = "候補配列(双子除外後)"
   ThisWorkbook.Worksheets("sheet1").Range("O20").Value = 効果
   For 行 = 1 To 9
      For 列 = 1 To 9
         ThisWorkbook.Worksheets("sheet1").Range("K21").Cells(行, 列).Value = 候補配列(行, 列, 2)
      Next 列
   Next 行
'   Stop

End Sub


'**************************************************************************
Private Sub トリプル除外()
'**************************************************************************
   Dim トリプル候補1 As String
   Dim トリプル候補2 As String
   Dim トリプル文字列 As String
   Dim トリプルS1 As String
   Dim トリプルS2 As String
   Dim トリプルS3 As String
   Dim ダブル文字列1 As String
   Dim ダブル文字列2 As String
   Dim トリプル数 As Integer
   Dim 行 As Integer
   Dim 列 As Integer
   Dim ブロック横 As Integer
   Dim ブロック縦 As Integer

'  候補配列(9, 9, 2) As Variant '行、列、候補数、候補文字列

   効果 = False
   '********************************************************************
   '横方向のトリプル並びを見つける
   For 行 = 1 To 9
      '1行毎に、各セルの候補で、二つの同一候補の有無を確認開して、候補がユニークな列を見つける
      トリプル文字列 = ""
      トリプル候補1 = ""
      トリプル候補2 = ""
      ダブル文字列1 = ""
      ダブル文字列2 = ""
      トリプル数 = 0
      
      For 列 = 1 To 9
         If 1 < 候補配列(行, 列, 1) And 候補配列(行, 列, 1) <= 3 Then
            トリプル数 = トリプル数 + 1
         End If
      Next 列
      
      If トリプル数 >= 3 Then
      'トリプルの候補が、3桁、3桁、2桁、2桁と4つ有って、3桁、2桁、2桁がトリプルを形成する場合がある
'      stop
         For 列 = 1 To 9
            If 候補配列(行, 列, 1) = 3 Then
               If トリプル候補1 = "" Then
                  トリプル候補1 = 候補配列(行, 列, 2)
               ElseIf トリプル候補1 = 候補配列(行, 列, 2) Then
                  トリプル文字列 = トリプル候補1   '3桁で同一が2つあれば、トリプル文字列決定
               ElseIf トリプル候補2 = "" Then
                  トリプル候補2 = 候補配列(行, 列, 2)
               ElseIf トリプル候補2 = 候補配列(行, 列, 2) Then
                  トリプル文字列 = トリプル候補2   '3桁で同一が2つあれば、トリプル文字列決定
               End If
            ElseIf 候補配列(行, 列, 1) = 2 Then
               If ダブル文字列1 = "" Then
                  ダブル文字列1 = 候補配列(行, 列, 2)
               ElseIf ダブル文字列1 = 候補配列(行, 列, 2) Then

               ElseIf ダブル文字列2 = "" Then
                  ダブル文字列2 = 候補配列(行, 列, 2)
               ElseIf ダブル文字列2 = 候補配列(行, 列, 2) Then

               End If
            End If
         Next 列
         
         '上でトリプル文字列が決まらなかった場合、2文字と一致した方をトリプル文字列とする
         If トリプル文字列 = "" Then
            If InStr(トリプル候補1, Left(ダブル文字列1, 1)) > 0 And InStr(トリプル候補1, Right(ダブル文字列1, 1)) > 0 Then
               トリプル文字列 = トリプル候補1
            ElseIf InStr(トリプル候補2, Left(ダブル文字列2, 1)) > 0 And InStr(トリプル候補2, Right(ダブル文字列2, 1)) > 0 Then
               トリプル文字列 = トリプル候補2
            End If
         End If
         
         '有効なトリプル数を集計
         トリプル数 = 0
         For 列 = 1 To 9
            If 候補配列(行, 列, 1) = 3 Then
               If トリプル文字列 = 候補配列(行, 列, 2) Then
                  '確定したトリプル文字列と同じものだけをカウント
                  トリプル数 = トリプル数 + 1
               End If
            End If
         Next 列

      End If
      
      If ダブル文字列1 <> "" Then
         If InStr(トリプル文字列, Left(ダブル文字列1, 1)) > 0 And InStr(トリプル文字列, Right(ダブル文字列1, 1)) > 0 Then
            トリプル数 = トリプル数 + 1
         End If
      End If
      If ダブル文字列2 <> "" Then
         If InStr(トリプル文字列, Left(ダブル文字列2, 1)) > 0 And InStr(トリプル文字列, Right(ダブル文字列2, 1)) > 0 Then
            トリプル数 = トリプル数 + 1
         End If
      End If
      
      トリプルS1 = Left(トリプル文字列, 2)
      トリプルS2 = Left(トリプル文字列, 1) & Right(トリプル文字列, 1)
      トリプルS3 = Right(トリプル文字列, 2)
      
      If トリプル数 >= 3 Then
         For 列 = 1 To 9
            If 候補配列(行, 列, 1) >= 3 And 候補配列(行, 列, 2) <> トリプル文字列 Then
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Left(トリプル文字列, 1), "")
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Mid(トリプル文字列, 2, 1), "")
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Right(トリプル文字列, 1), "")
               If 候補配列(行, 列, 1) > Len(候補配列(行, 列, 2)) Then
                  候補配列(行, 列, 1) = Len(候補配列(行, 列, 2))
                  効果 = True
                  候補配列変更 = True
               End If
            ElseIf 候補配列(行, 列, 1) = 2 And 候補配列(行, 列, 2) <> トリプルS1 _
            And 候補配列(行, 列, 2) <> トリプルS2 And 候補配列(行, 列, 2) <> トリプルS3 Then
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Left(トリプル文字列, 1), "")
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Mid(トリプル文字列, 2, 1), "")
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Right(トリプル文字列, 1), "")
               If 候補配列(行, 列, 1) > Len(候補配列(行, 列, 2)) Then
                  候補配列(行, 列, 1) = Len(候補配列(行, 列, 2))
                  効果 = True
                  候補配列変更 = True
               End If
            End If
         Next 列
      End If
   Next 行
   
   '********************************************************************
   '縦方向のトリプル並びを見つける
   For 列 = 1 To 9
      トリプル文字列 = ""
      トリプル候補1 = ""
      トリプル候補2 = ""
      ダブル文字列1 = ""
      ダブル文字列2 = ""
      トリプル数 = 0
      
      For 行 = 1 To 9
         If 1 < 候補配列(行, 列, 1) And 候補配列(行, 列, 1) <= 3 Then
            トリプル数 = トリプル数 + 1
         End If
      Next 行
      
      If トリプル数 >= 3 Then
      'トリプルの候補が、3桁、3桁、2桁、2桁と4つ有って、3桁、2桁、2桁がトリプルを形成する場合がある
'      stop
         For 行 = 1 To 9
            If 候補配列(行, 列, 1) = 3 Then
               If トリプル候補1 = "" Then
                  トリプル候補1 = 候補配列(行, 列, 2)
               ElseIf トリプル候補1 = 候補配列(行, 列, 2) Then
                  トリプル文字列 = トリプル候補1   '3桁で同一が2つあれば、トリプル文字列決定
               ElseIf トリプル候補2 = "" Then
                  トリプル候補2 = 候補配列(行, 列, 2)
               ElseIf トリプル候補2 = 候補配列(行, 列, 2) Then
                  トリプル文字列 = トリプル候補2   '3桁で同一が2つあれば、トリプル文字列決定
               End If
            ElseIf 候補配列(行, 列, 1) = 2 Then
               If ダブル文字列1 = "" Then
                  ダブル文字列1 = 候補配列(行, 列, 2)
               ElseIf ダブル文字列1 = 候補配列(行, 列, 2) Then

               ElseIf ダブル文字列2 = "" Then
                  ダブル文字列2 = 候補配列(行, 列, 2)
               ElseIf ダブル文字列2 = 候補配列(行, 列, 2) Then

               End If
            End If
         Next 行
         
          '上でトリプル文字列が決まらなかった場合、2文字と一致した方をトリプル文字列とする
         If トリプル文字列 = "" Then
            If InStr(トリプル候補1, Left(ダブル文字列1, 1)) > 0 And InStr(トリプル候補1, Right(ダブル文字列1, 1)) > 0 Then
               トリプル文字列 = トリプル候補1
            ElseIf InStr(トリプル候補2, Left(ダブル文字列2, 1)) > 0 And InStr(トリプル候補2, Right(ダブル文字列2, 1)) > 0 Then
               トリプル文字列 = トリプル候補2
            End If
         End If

         '有効なトリプル数を集計
         トリプル数 = 0
         For 行 = 1 To 9
            If 候補配列(行, 列, 1) = 3 Then
               If トリプル文字列 = 候補配列(行, 列, 2) Then
                  '確定したトリプル文字列と同じものだけをカウント
                  トリプル数 = トリプル数 + 1
               End If
            End If
         Next 行
         
      End If
      
      If ダブル文字列1 <> "" Then
         If InStr(トリプル文字列, Left(ダブル文字列1, 1)) > 0 And InStr(トリプル文字列, Right(ダブル文字列1, 1)) > 0 Then
            トリプル数 = トリプル数 + 1
         End If
      End If
      If ダブル文字列2 <> "" Then
         If InStr(トリプル文字列, Left(ダブル文字列2, 1)) > 0 And InStr(トリプル文字列, Right(ダブル文字列2, 1)) > 0 Then
            トリプル数 = トリプル数 + 1
         End If
      End If
      
      トリプルS1 = Left(トリプル文字列, 2)
      トリプルS2 = Left(トリプル文字列, 1) & Right(トリプル文字列, 1)
      トリプルS3 = Right(トリプル文字列, 2)
      
      If トリプル数 >= 3 Then
         For 行 = 1 To 9
            If 候補配列(行, 列, 1) >= 3 And 候補配列(行, 列, 2) <> トリプル文字列 Then
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Left(トリプル文字列, 1), "")
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Mid(トリプル文字列, 2, 1), "")
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Right(トリプル文字列, 1), "")
               If 候補配列(行, 列, 1) > Len(候補配列(行, 列, 2)) Then
                  候補配列(行, 列, 1) = Len(候補配列(行, 列, 2))
                  効果 = True
                  候補配列変更 = True
               End If
            ElseIf 候補配列(行, 列, 1) = 2 And 候補配列(行, 列, 2) <> トリプルS1 _
            And 候補配列(行, 列, 2) <> トリプルS2 And 候補配列(行, 列, 2) <> トリプルS3 Then
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Left(トリプル文字列, 1), "")
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Mid(トリプル文字列, 2, 1), "")
               候補配列(行, 列, 2) = Replace(候補配列(行, 列, 2), Right(トリプル文字列, 1), "")
               If 候補配列(行, 列, 1) > Len(候補配列(行, 列, 2)) Then
                  候補配列(行, 列, 1) = Len(候補配列(行, 列, 2))
                  効果 = True
                  候補配列変更 = True
               End If
            End If
         Next 行
      End If
   Next 列

   '********************************************************************
   'ブロック方向のトリプル並びを見つける
   For ブロック縦 = 0 To 2
      For ブロック横 = 0 To 2
         トリプル文字列 = ""
         トリプル候補1 = ""
         トリプル候補2 = ""
         ダブル文字列1 = ""
         ダブル文字列2 = ""
         トリプル数 = 0
         
         For 行 = 1 To 3
            For 列 = 1 To 3
               If 1 < 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) _
               And 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) <= 3 Then
                  トリプル数 = トリプル数 + 1
               End If
            Next 列
         Next 行
      
         If トリプル数 >= 3 Then
         'トリプルの候補が、3桁、3桁、2桁、2桁と4つ有って、3桁、2桁、2桁がトリプルを形成する場合がある
   '      stop
            For 行 = 1 To 3
               For 列 = 1 To 3
                  If 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) = 3 Then
         '            Stop
                     If トリプル候補1 = "" Then
                        トリプル候補1 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2)
                     ElseIf トリプル候補1 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) Then
                        トリプル文字列 = トリプル候補1   '3桁で同一が2つあれば、トリプル文字列決定
                     ElseIf トリプル候補2 = "" Then
                        トリプル候補2 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2)
                     ElseIf トリプル候補2 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) Then
                        トリプル文字列 = トリプル候補2   '3桁で同一が2つあれば、トリプル文字列決定
                     End If
         
                  ElseIf 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) = 2 Then
                     If ダブル文字列1 = "" Then
                        ダブル文字列1 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2)
                     ElseIf ダブル文字列1 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) Then
      
                     ElseIf ダブル文字列2 = "" Then
                        ダブル文字列2 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2)
                     ElseIf ダブル文字列2 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) Then
      
                     End If
                  End If
               Next 列
            Next 行
            
            '上でトリプル文字列が決まらなかった場合、2文字と一致した方をトリプル文字列とする
            If トリプル文字列 = "" Then
               If InStr(トリプル候補1, Left(ダブル文字列1, 1)) > 0 And InStr(トリプル候補1, Right(ダブル文字列1, 1)) > 0 Then
                  トリプル文字列 = トリプル候補1
               ElseIf InStr(トリプル候補2, Left(ダブル文字列2, 1)) > 0 And InStr(トリプル候補2, Right(ダブル文字列2, 1)) > 0 Then
                  トリプル文字列 = トリプル候補2
               End If
            End If

            '有効なトリプル数を集計
            トリプル数 = 0
            For 行 = 1 To 3
               For 列 = 1 To 3
                  If 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) = 3 Then
                     If トリプル文字列 = 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) Then
                        '確定したトリプル文字列と同じものだけをカウント
                        トリプル数 = トリプル数 + 1
                     End If
                  End If
               Next 列
            Next 行
            
         End If
         
         If ダブル文字列1 <> "" Then
            If InStr(トリプル文字列, Left(ダブル文字列1, 1)) > 0 And InStr(トリプル文字列, Right(ダブル文字列1, 1)) > 0 Then
               トリプル数 = トリプル数 + 1
            End If
         End If
         If ダブル文字列2 <> "" Then
            If InStr(トリプル文字列, Left(ダブル文字列2, 1)) > 0 And InStr(トリプル文字列, Right(ダブル文字列2, 1)) > 0 Then
               トリプル数 = トリプル数 + 1
            End If
         End If
         
         トリプルS1 = Left(トリプル文字列, 2)
         トリプルS2 = Left(トリプル文字列, 1) & Right(トリプル文字列, 1)
         トリプルS3 = Right(トリプル文字列, 2)
         
         If トリプル数 >= 3 Then
            For 行 = 1 To 3
               For 列 = 1 To 3
                  If 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) >= 3 _
                  And 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) <> トリプル文字列 Then
                     候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) _
                     = Replace(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2), Left(トリプル文字列, 1), "")
                     候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) _
                     = Replace(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2), Mid(トリプル文字列, 2, 1), "")
                     候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) _
                     = Replace(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2), Right(トリプル文字列, 1), "")
                     If 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) _
                     > Len(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2)) Then
                        候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) _
                        = Len(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2))
                        効果 = True
                        候補配列変更 = True
                     End If
                  ElseIf 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) = 2 _
                  And 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) <> トリプルS1 _
                  And 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) <> トリプルS2 _
                  And 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) <> トリプルS3 Then
                     候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) _
                     = Replace(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2), Left(トリプル文字列, 1), "")
                     候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) _
                     = Replace(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2), Mid(トリプル文字列, 2, 1), "")
                     候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2) _
                     = Replace(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2), Right(トリプル文字列, 1), "")
                     If 候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) _
                     > Len(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2)) Then
                        候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 1) _
                        = Len(候補配列(ブロック縦 * 3 + 行, ブロック横 * 3 + 列, 2))
                        効果 = True
                        候補配列変更 = True
                     End If
                  End If
               Next 列
            Next 行
         End If
      Next ブロック横
   Next ブロック縦

'   候補配列書き出し
   ThisWorkbook.Worksheets("sheet1").Range("K20").Value = "候補配列(トリプル除外後)"
   ThisWorkbook.Worksheets("sheet1").Range("O20").Value = 効果
   For 行 = 1 To 9
      For 列 = 1 To 9
         ThisWorkbook.Worksheets("sheet1").Range("K21").Cells(行, 列).Value = 候補配列(行, 列, 2)
      Next 列
   Next 行
'   Stop

End Sub


'**************************************************************************
Sub 数独マスキング()
'**************************************************************************
   Dim 解決 As Boolean
   Dim 行 As Integer
   Dim 列 As Integer
   Dim トライ数 As Integer
   
   ステップ表示 = False
   トライ数 = 0
   
   '先に数表作成が終わっているかチェック
   For 行 = 1 To 9
      For 列 = 1 To 9
         If ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = "0" _
            Or ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = "" Then
            MsgBox "表内に空白か 0 が残っています。先に「数独数表作成」を実行して下さい。"
            End
         End If
      Next 列
   Next 行
   
   開始日時 = Now                ' 開始時刻を変数に格納します。
   
   ThisWorkbook.Worksheets("sheet1").Range("A1:I9").Copy Range("A11")
   
   ThisWorkbook.Worksheets("sheet1").Range("A11:I19").Font.ColorIndex = 2
   
   Do
      トライ数 = トライ数 + 1
      Application.DisplayStatusBar = True
      Application.StatusBar = "★ トライ数 = " & トライ数 & " ★"
      
      Call 数独マスキング本体
      
      解決 = False
      Call 数独解決本体(解決)
      
      If 解決 = False Then
         ThisWorkbook.Worksheets("sheet1").Range("A1:I9").Interior.Pattern = xlNone
         ThisWorkbook.Worksheets("sheet1").Range("A11:I19").Copy
         Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
         SkipBlanks:=False, Transpose:=False
      Else
         ThisWorkbook.Worksheets("sheet1").Range("A1:I9").Interior.ColorIndex = xlColorIndexNone
         ThisWorkbook.Worksheets("sheet1").Range("A1").Select
      End If
   
   Loop While 解決 = False
   
   'マスクをセルに反映
   For 行 = 1 To 9
      For 列 = 1 To 9
         If 配列マスク(行, 列) = "黒" Then
            ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = ""
         End If
      Next 列
   Next 行
   
   終了日時 = Now
   
   MsgBox "マスキング 完成！   トライ数 = " & トライ数 & vbNewLine _
   & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
End Sub


'**************************************************************************
Sub 数独マスキング本体()
'**************************************************************************

   Dim 行 As Integer
   Dim 列 As Integer
   Dim 数 As Integer
   Dim 重複 As Boolean
   Dim ブロック横 As Integer
   Dim ブロック縦 As Integer
   Dim カウンタ As Integer
   Dim 列黒カウント As Integer
   Dim 行黒カウント As Integer
   Dim 黒カウント最少 As Integer
   Dim 最少列 As Integer
   Dim 最少行 As Integer
   Dim フィルタ数 As Integer
   
   Erase 配列マスク

   フィルタ数 = ThisWorkbook.Worksheets("sheet1").Range("K5").Value
   
   For ブロック縦 = 0 To 2
      For ブロック横 = 0 To 2
         For カウンタ = 1 To フィルタ数   '重複を考慮して、1ブロックに 6個程度を空白にする
            配列マスク(ブロック縦 * 3 + 乱数(3, 11) \ 3, ブロック横 * 3 + (乱数(3, 11) Mod 3) + 1) = "黒"
         Next カウンタ
      Next ブロック横
   Next ブロック縦
   
   'マスクをセルに反映
   For 行 = 1 To 9
      For 列 = 1 To 9
         If 配列マスク(行, 列) = "黒" Then
            ThisWorkbook.Worksheets("sheet1").Range("A1").Cells(行, 列).Value = ""
         End If
      Next 列
   Next 行
   
End Sub


'**************************************************************************
Function 可能性(数 As Integer, 対象列 As Integer) As Boolean
   Dim 行 As Integer
   Dim 列 As Integer
   Dim 重複 As Boolean
   
   可能性 = False
      
   For 行 = 1 To 9
      If 配列(行, 対象列) = 0 Then
         重複 = False
         For 列 = 1 To 9
            If 配列(行, 列) = 数 Then
               重複 = True
            End If
         Next 列
         If 重複 = False Then
            可能性 = True
            Exit For
         End If
      End If
      If 可能性 = True Then
         Exit For
      End If
   Next 行
   
End Function

'**************************************************************************
Function 行内重複(行 As Integer, 数 As Integer) As Boolean
   Dim 列 As Integer
   Dim 重複 As Boolean
   
   For 列 = 1 To 9
      If 配列(行, 列) = 数 Then
         重複 = True
         Exit For
      End If
   Next 列
   
   If 重複 = True Then
      行内重複 = True
   Else
      行内重複 = False
   End If

End Function

'**************************************************************************
Function ブロック重複(縦 As Integer, 横 As Integer, 数 As Integer) As Boolean
   Dim 行 As Integer
   Dim 列 As Integer
   Dim 重複 As Boolean
   
   For 行 = 1 To 3
      For 列 = 1 To 3
         If 配列(縦 * 3 + 行, 横 * 3 + 列) = 数 Then
            重複 = True
            Exit For
         End If
      Next 列
   Next 行
   
   If 重複 = True Then
      ブロック重複 = True
   Else
      ブロック重複 = False
   End If
   
End Function


'**************************************************************************
Function 個数(ByVal 文字列 As String) As Integer
   Dim カウンタ As Integer
   
   個数 = 0
   For カウンタ = 1 To Len(文字列)
      個数 = 個数 + Val(Mid(文字列, カウンタ, 1))
   Next カウンタ
End Function

'**************************************************************************
Function 乱数(ByVal 最初 As Integer, ByVal 最後 As Integer) As Integer
   '' 目が 1〜DiceMe の範囲の乱数を生成
   '' 乱数発生器に種をまいて、毎回、同じ系列にならないようにします。
   Randomize
   乱数 = Int(Rnd * (最後 - 最初 + 1) + 最初)
End Function

'**************************************************************************
Sub 乱数テスト()
   Dim カウンタ As Integer
   
   For カウンタ = 1 To 20
      Debug.Print 乱数(11, 16);
   Next カウンタ

End Sub

この種類の目次に戻る↑　索引へ↓　トップページに戻る

ホームページのトップに戻る