[[20200426185317]]　『数独・ナンプレの解答をランダムで作りたい』（asa）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『数独・ナンプレの解答をランダムで作りたい』（asa）

数独・ナンプレ(9×9)の解答をランダムに作成したいです。
縦横に1-9、3×3に1-9がそれぞれ入る、普通の数独の、問題ではなく解答の盤をEXCELの関数やマクロを駆使して作りたいのですが、知識不足で、案がありません。ご教示ください。

＜ 使用 Excel：Office365、使用 OS：Windows10 ＞

---

"数独解法プログラム　VBA"などと検索するとよいでしょう。
例えば、下記にはコードを読めるBookが公開されているようです。

https://excel-ubara.com/excelvba5/EXCELVBA230.html

（γ） 2020/04/26(日) 19:40

---

返信ありがとうございます。リンクにあったサンプルファイルをダウンロードし、実行してみましたが解析ソフトなので、全マス空欄の状態でのランダム出力はできませんでした。同じ盤面しか出力されませんでした。
数独の完成図がランダムに出力できる方法はありますでしょうか？
一応、補足もしておきます。

補足

自分は趣味として、数独を作成しているのですが、作成するとき、一つの作成方法として、完成盤面を作成し、その後いくつかの空欄を作り、完成させるという方法を取っています。エクセルを使うことで、完成盤面の作成を省こうと思っているのです。
（asa） 2020/04/26(日) 20:52

---

一列目に9個の数値をランダムに並び替えて、
1列目だけを与えた問題を作って回答を得ることで、
相当の数（9!)の完成形は作れそうですが。

取りあえず別のことをしないといけないので、
他の回答者のコメントをお待ち下さい。
（ γ） 2020/04/26(日) 21:23

---

A1:I9に作成された組み合わせを
ランダムに数値シャッフル、列シャッフル、行シャッフルして、１０行ずつずらし表示します。
ランダムですのでシャッフルされない場合もあります。

Sub シャッフル()

    Dim s As String
    Dim i As Long, j As Long, j1 As Long, j2 As Long, k As Long
    Dim x1, x2, xx
    Randomize
    '数字シャッフル
    s = "123456789"
    For i = 1 To 9
        j = Int(Rnd() * 9 + 1)
        s = j & Replace(s, j, "")
    Next
    With Range("a1").Resize(9, 9)
        xx = .Value
        For i = 1 To 9
            For j = 1 To 9
                xx(i, j) = Mid(s, xx(i, j), 1)
            Next
        Next
        .Offset(10).Value = xx
    '列シャッフル
        For i = 1 To 9 Step 3
            j1 = Int(Rnd() * 3) + i
            j2 = Int(Rnd() * 3) + i
            x1 = Application.Index(xx, 0, j1)
            x2 = Application.Index(xx, 0, j2)
            For j = 1 To 9
                xx(j, j1) = x2(j, 1)
                xx(j, j2) = x1(j, 1)
            Next
        Next
        .Offset(20).Value = xx
    '行シャッフル
        For i = 1 To 9 Step 3
            j1 = Int(Rnd() * 3) + i
            j2 = Int(Rnd() * 3) + i
            x1 = Application.Index(xx, j1, 0)
            x2 = Application.Index(xx, j2, 0)
            For j = 1 To 9
                xx(j1, j) = x2(j)
                xx(j2, j) = x1(j)
            Next
        Next
        .Offset(30).Value = xx
    End With
End Sub
（kazuo） 2020/04/26(日) 22:30

---

 こんばんは！
昔に書いたコードの使いまわしですけど、、ちょっと書いてみました。
乱数は↓ここから拝借しております。
http://www001.upp.so-net.ne.jp/isaku/mt.html

 3×3　を　3セットづつ作ればいいんですよね？？？
偏ってないと思いますが、、、偏っている様にも見える(^^;
まぁ、、何かの参考程度でお願いします。。。。
もう寝ます。
おやすみなさいzzzzzzzzzzzzzzzzzzzz

 Option Explicit
 ' ＶＢＡによるメルセンヌツイスタ
' システムを起動してからの時間をミリ秒単位で返す
' http://msdn.microsoft.com/ja-jp/library/cc429827.aspx
Private Declare Function GetTickCount Lib "kernel32" () As Long
' メルセンヌツイスタのパラメータ(ダイナミッククリエーターの結果)
Private Const MTN = 644, MTM = 322, MTA = 12, MTB = 7, MTC = 15, MTD = 18
Private Const MXA = &H70C20000, UMK = &H78000000, LMK = &H7FFFFFF
Private Const MKB = &H73736B80, MKC = &H6ED28000
' 補助的な定数の宣言
Private Const MTL = MTN - MTM, MTK = MTN - 1, MTJ = MTL - 1, MTP = MTN - 2
Private Const PWA = 2 ^ MTA, PWB = 2 ^ MTB, PWC = 2 ^ MTC, PWD = 2 ^ MTD
Private Const KB = MKB \ PWB, KC = MKC \ PWC
Private Const P32 = 2# ^ 32, P31 = 2 ^ 31, P22 = 2# ^ 22, P9 = 2 ^ 9
Private Const M53 = 2# ^ -53, M32 = 2# ^ -32, M30 = 2# ^ -30
' 乱数の状態
Private mt(0 To MTK), mti As Long
' 初期化の補助関数
Private Function Ri(ByRef r As Double, ByVal i As Long) As Long
    Dim s As Variant
    Dim shft As Double
    Dim a As Long
    If r >= P31 Then a = r - P32 Else a = r
    a = a Xor Int(r * M30)
    If a < 0 Then r = a + P32 Else r = a
    s = 1812433253 * CDec(r) + i: r = s - CDec(Int(s * M32)) * P32
    If r >= P31 Then Ri = r - P31 Else Ri = r
End Function
' s を種にして乱数を初期化する
Public Sub InitMt(ByVal s As Long)
    Dim r As Double
    mt(0) = s And &H7FFFFFFF
    If s < 0 Then r = P32 + s Else r = s
    For mti = 1 To MTK: mt(mti) = Ri(r, mti): Next mti
    mti = MTN
End Sub
' 31 ビットの整数乱数
Public Function NextMt() As Long
    Dim y, k As Long
    If mti = 0 Then InitMt (1)
    If mti = MTN Then
        mti = 0
        For k = 0 To MTJ
            y = (mt(k) And UMK) Or (mt(k + 1) And LMK)
            mt(k) = mt(k + MTM) Xor (y \ 2) Xor (-(y And 1) And MXA)
        Next k
        For k = MTL To MTP
            y = (mt(k) And UMK) Or (mt(k + 1) And LMK)
            mt(k) = mt(k - MTL) Xor (y \ 2) Xor (-(y And 1) And MXA)
        Next k
        y = (mt(MTK) And UMK) Or (mt(0) And LMK)
        mt(MTK) = mt(MTM - 1) Xor (y \ 2) Xor (-(y And 1) And MXA)
    End If
    y = mt(mti): mti = mti + 1
    y = y Xor (y \ PWA): y = y Xor ((y And KB) * PWB)
    y = y Xor ((y And KC) * PWC): y = y Xor (y \ PWD): NextMt = y
End Function
' 0 以上 1 未満の乱数を返す
Public Function NextUnifMt() As Double
    Dim x As Long
    x = NextMt \ P9: NextUnifMt = (NextMt * P22 + x) * M53
End Function
' 時間を種にして乱数を初期化する
Public Sub RandomizeMt()
    InitMt (GetTickCount())
End Sub

 Sub てすと()
Dim MyA As Variant
Dim MyB As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim ii As Long
Dim jj As Long
MyA = Split("1,2,3,4,5,6,7,8,9", ",")
ReDim MyB(1 To 9, 1 To 9)
For ii = 0 To 6 Step 3
    For jj = 0 To 6 Step 3
        k = 0
        MyFScs MyA
        For i = 1 To 3
            For j = 1 To 3
                MyB(i + ii, j + jj) = MyA(k)
                k = k + 1
            Next
        Next
    Next
Next
Range("A1").Resize(UBound(MyB, 1), UBound(MyB, 2)).Value = MyB
Erase MyA, MyB
End Sub
Private Sub MyFScs(ByRef x As Variant)
Dim y As Variant
Dim i As Long
Dim j As Long
Dim MyScs As Object
    Set MyScs = CreateObject("System.Collections.SortedList")
    ReDim y(LBound(x, 1) To UBound(x, 1))
    RandomizeMt
    For i = LBound(x, 1) To UBound(x, 1)
        MyScs(NextUnifMt()) = i
    Next
    For i = 0 To MyScs.Count - 1
        y(i) = x(MyScs.GetByIndex(i))
    Next
    x = y
    Set MyScs = Nothing
    Erase y
End Sub
（SoulMan） 2020/04/27(月) 00:33

---

 作った(9×9)マスをひっくり返したり、横にしたり・・・。
（BJ） 2020/04/27(月) 12:50

---

  トライアンドエラーのスパゲッティコードですが、
  とりあえず作成できるみたいなので、新規シートでお試しください。
  ※　尚　中断したい時は {Ctrl}+{Break}で止めてください。

 Sub 問題作成()
     Dim R As Long, C As Long, i As Long, LC As Long
     Dim No As Long, Box As Range
     Dim X As Range, W As Range
     Dim wNo As String
     Do
         Cells(1, 1).Resize(9, 9).ClearContents
         wNo = 順番
         i = 0
         For Each X In Cells(7, 7).Resize(3, 3)
             i = i + 1
             X.Value = Mid(wNo, i, 1)
         Next
         '-----
         For R = 7 To 1 Step -3
             For C = 7 To 1 Step -3
                 Set Box = Cells(R, C).Resize(3, 3)
                 If R = 7 And C = 7 Then
                 ElseIf (R = 1 And C = 1) Then
                     wNo = "123456789"
                     Box.ClearContents
                     For Each W In Box
                         For i = 1 To 9
                             No = Val(Mid(wNo, i, 1))
                             If WorksheetFunction.CountIf(W.Resize(9, 1), No) = 0 Then
                             If WorksheetFunction.CountIf(W.Resize(1, 9), No) = 0 Then
                                 W.Value = Val(No)
                                 Exit For
                             End If
                             End If
                         Next
                     Next
                     DoEvents
                     If WorksheetFunction.CountBlank(Box) = 0 Then Exit Do
                 Else
                     LC = 0
                     Do
                         wNo = 順番
                         Box.ClearContents
                         For Each W In Box
                            For i = 1 To Len(wNo)
                                 No = Val(Mid(wNo, i, 1))
                                 If WorksheetFunction.CountIf(W.Resize(9, 1), No) = 0 Then
                                 If WorksheetFunction.CountIf(W.Resize(1, 9), No) = 0 Then
                                     W.Value = Val(No)
                                     wNo = Replace(wNo, CStr(No), "")
                                     Exit For
                                 End If
                                 End If
                             Next
                         Next
                         DoEvents
                         LC = LC + 1
                         If LC >= 10 Then Exit Do
                     Loop While WorksheetFunction.CountBlank(Box) <> 0
                 End If
                 If WorksheetFunction.CountBlank(Box) <> 0 Then Exit For
             Next
             If WorksheetFunction.CountBlank(Box) <> 0 Then Exit For
         Next
     Loop
     MsgBox "完了"
 End Sub
 Function 順番() As String
     Dim W9   As String
     Dim i As Long
     Dim X As Range, W As Range
     Set X = Cells(1, 21).Resize(9, 1)
     X.Formula = "=rand()"
     X.Value = X.Value
     For i = 1 To 9
         W9 = W9 & WorksheetFunction.Rank(Cells(i, 21), Cells(1, 21).Resize(9, 1))
     Next
     順番 = W9
 End Function

（チオチモリン） 2020/04/27(月) 18:47

---

 こんばんは！
ただ作るだけじゃだめなんですね？？？(^^;
乱数のところは上のコードをそのまま使用して頂くとしてちょっと入れ替えてみました。。。
途中同じパターンになるところがあります。。。(多分？？？？）
後は、、応用して頂けると助かります。。。
あっ、、罫線も付けておきました。。。。
では、、では、、、また、、、

 Sub 改造問題作成配列最終版()
Dim MyA As Variant
Dim i As Long
Dim BoxNo As String
Dim 総合判定 As Boolean
Static カウンター As Boolean
i = 1
With Range("A1").Resize(9, 9)
    .ClearContents
    ReDim MyA(1 To 9, 1 To 9)
    Application.ScreenUpdating = False
        Do
            BoxNo = Mid("012345678", i, 1)
            総合判定 = False
            BoxSub MyA, CLng(BoxNo), 総合判定
            If 総合判定 Then
                i = i + 1
            Else
                i = 1
                ReDim MyA(1 To 9, 1 To 9)
            End If
        Loop While i < 10
        Range("A1").Resize(UBound(MyA, 1), UBound(MyA, 2)).Value = MyA
        If カウンター = False Then
            .Borders.LineStyle = xlContinuous
            With Range("A4:I6")
                .Borders(xlEdgeTop).Weight = xlMedium
                .Borders(xlEdgeBottom).Weight = xlMedium
            End With
            With Range("D1:F9")
                .Borders(xlEdgeLeft).Weight = xlMedium
                .Borders(xlEdgeRight).Weight = xlMedium
            End With
            .BorderAround Weight:=xlMedium
        End If
        カウンター = True
    Application.ScreenUpdating = True
End With
MsgBox "完了"
Erase MyA
End Sub
Sub BoxSub(ByRef MyA As Variant, ByVal BoxNo As Long, ByRef 総合判定 As Boolean)
Dim i As Long, 回数 As Long
Dim r As Long, c As Long
Dim No As Long
Dim 候補 As String
Dim 判定 As Boolean
Dim 行列 As Variant
Dim 行 As Variant
Dim 列 As Variant
Dim v As Variant
Dim ri As Long
Dim cj As Long
Dim n As Long
Dim MyFlg As Boolean
Dim TempMyA As Variant
行列 = Array("1,1", "1,4", "4,1", "1,7", "7,1", "4,4", "4,7", "7,4", "7,7")
r = Split(行列(BoxNo), ",")(0)
c = Split(行列(BoxNo), ",")(1)
回数 = 0
Do
    TempMyA = MyA
    MyFlg = False
    v = Split("1,2,3,4,5,6,7,8,9", ",")
    MyFScs v
    候補 = Join(v, "")
    For ri = 0 To 2
        For cj = 0 To 2
            For i = 1 To Len(候補)
                No = Val(Mid(候補, i, 1))
                行 = Application.Index(MyA, r + ri, 0)
                列 = Application.Transpose(Application.Index(MyA, 0, c + cj))
                If UBound(Filter(行, No, True)) Then
                    If UBound(Filter(列, No, True)) Then
                        MyA(r + ri, c + cj) = Val(No)
                        候補 = Replace(候補, CStr(No), "")
                        Exit For
                    End If
                End If
            Next
        Next
    Next
    チェック MyA, r, c, MyFlg
    If MyFlg Then
        Select Case BoxNo
            Case 0 To 7
                回数 = 回数 + 1
                If 回数 >= 10 Then
                    判定 = False
                    MyA = TempMyA
                    Exit Do
                End If
            Case 8
                判定 = False
                MyA = TempMyA
                Exit Do
        End Select
    Else
        判定 = True
        Exit Do
    End If
Loop
総合判定 = 判定
Erase 行列, 行, 列, v, TempMyA
End Sub
Private Sub MyFScs(ByRef x As Variant)
Dim y As Variant
Dim i As Long
Dim j As Long
Dim MyScs As Object
Set MyScs = CreateObject("System.Collections.SortedList")
ReDim y(LBound(x, 1) To UBound(x, 1))
RandomizeMt
For i = LBound(x, 1) To UBound(x, 1)
    MyScs(NextUnifMt()) = i
Next
For i = 0 To MyScs.Count - 1
    y(i) = x(MyScs.GetByIndex(i))
Next
x = y
Set MyScs = Nothing
Erase y
End Sub
Sub チェック(ByRef v As Variant, ByVal ii As Long, ByVal jj As Long, ByRef MyFlg As Boolean)
Dim i As Long
Dim j As Long
For i = 0 To 2
    For j = 0 To 2
        If IsEmpty(v(ii + i, jj + j)) Then
            MyFlg = True
            Exit For
        End If
    Next
Next
End Sub

 こんにちは！
いやぁ難しいです。(^^;
ちょっと私には無理そうなので　チオチモリン　さんのコードをお借りして
乱数をNextUnifMtにして上から書き込んで行く様にしてみました。
意味はありません。自己研鑽です。すみません。

 何年かして他の誰かが見に来られることもあるでしょうから参考出展させてください。
では、、では、、また。。。
2020/05/01 10:52

 シート上よりも配列の中の方が多少なりともスピードUp期待出来るので
配列に置き換えてみました。コードは変わりません。。。。
すみません。参考出展です。。。。m(__)m
2020/05/01 21:20

 すみません。初期化→TempMyAにしました。
2020/05/03　12:03
（SoulMan） 2020/04/27(月) 20:35

---

 参考サイトを紹介しておきます。

 (1)「ナンプレ完成形はどこまで増やせる？」
 http://www20.big.or.jp/~morm-e/puzzle/column/001/001.html

 (2)「数独の例題生成 - ネットワークシステム研究室」
 http://www.net.c.dendai.ac.jp/~ynakajima/index.htm

 本文ここまでです。

 =================================================
 【以下は余談です。お急ぎの方はスキップ下さい】

 既に提示いただいているコードで結果は得られますが、
 上記(2)の記事に掲載されている、「バックトラック法」を用いたコードを
 試してみました。

 関係するのは、
 mainの一部
 check
 rand9
 canBePlaced（縦、横、3×3のブロック（9個）に１〜９が重複無く配置されているかをチェック）
 などくらいです。

 ちなみに、自分の学習を兼ねて、VBAとは別の言語で書いてみましたら、
 1000個の数独パターンを 0.8秒くらいで作成できました。

 ちなみに、バックトラック法を用いると、この場合、行き止まりになった再帰処理が
 積み重なっていくわけですが、正解にたどり着いた段階で、それらの閉じられていない
 プロシージャをなんらかの手段で閉じる必要があります。

 記事にあるC言語のコードでは、try catch構文を使用して対応しています。
 （つまり、9×9の完成形に達したら、例外を投げて大域的ジャンプをしています。
  これで、同時に関数スタックがすべてクリアーされるわけです。）

 ところが、VBAにはこうした機構が無いので立ち往生します。
 普通は、On error　と Err.Raiseの意図的発生とを組み合わせるんでしょうが、
 この場合は複数回繰り返すと、一回目の数独作成は成功しますが、
 二度目のErr.Raiseの意図的発生で不可解なエラーが起きてしまい、
 なんとも解決できない状況です。これは困ったなあ、という感じです。

 愚痴になりましたのでこの辺で。

（ γ） 2020/04/27(月) 23:13

---

質問の趣旨とは異なりますが、
γさんの説明でお気づきでしょうが、数独問題は完成盤面としては一通りだけ有れば良いのです。
それよりも見た目は除きますが、無駄な公開マスを少なくし、回答が唯一になるように作るのが大切です。

 １．数字の入れ替え　ｘ362880
 ２．90度回転　　　　　ｘ2
 ３．ブロック入れ替え　x6
 ４．行列入れ替え　　　x36

プロシージャ名をアレンジとし、理論的には１回のアレンジで４．が36通りからになるようにし、３．を追加しました。
但し、２．は除いてあります。
ですので、１つの問題でアレンジすることにより、6千万とおりの問題が作成できることになります。

Sub アレンジ()

    Dim s As String
    Dim i As Long, j As Long
    Dim xx
    Randomize
    With Range("a1").Resize(9, 9)
        If WorksheetFunction.CountBlank(.Cells) = 9 * 9 Then
            .Offset(0).Resize(3).Value = [{6,0,8,0,3,0,0,7,0;1,7,0,8,0,5,0,0,0;0,0,0,0,7,0,0,0,0}]
            .Offset(3).Resize(3).Value = [{0,8,3,0,0,0,0,4,0;0,0,0,0,0,0,0,0,0;5,0,9,0,0,0,6,0,0}]
            .Offset(6).Resize(3).Value = [{0,9,0,0,4,0,7,8,0;7,2,0,0,5,0,9,1,0;0,0,0,0,0,1,0,3,0}]
            .Replace "0", ""
        End If
        xx = .Value
    '数字シャッフル
        s = "123456789"
        For i = 1 To 9
            j = Int(Rnd() * 9 + 1)
            s = j & Replace(s, j, "")
        Next
        For i = 1 To 9
            For j = 1 To 9
                If xx(i, j) <> "" Then xx(i, j) = Mid(s, xx(i, j), 1)
            Next
        Next
        For i = 1 To 2
            列シャッフル xx
        Next
        For i = 1 To 2
            行シャッフル xx
        Next
        For i = 1 To 2
            xx = 列ブロックシャッフル(xx)
        Next
        For i = 1 To 2
            xx = 行ブロックシャッフル(xx)
        Next
        .Value = xx
    End With
End Sub

Private Sub 列シャッフル(ByRef xx)

    Dim i As Long, j As Long, j1 As Long, j2 As Long
    Dim x1, x2
    For i = 1 To 9 Step 3
        j1 = Int(Rnd() * 3) + i
        j2 = Int(Rnd() * 3) + i
        If j1 = j2 Then Exit Sub
        x1 = Application.Index(xx, 0, j1)
        x2 = Application.Index(xx, 0, j2)
        For j = 1 To 9
            xx(j, j1) = x2(j, 1)
            xx(j, j2) = x1(j, 1)
        Next
    Next
End Sub

Private Sub 行シャッフル(ByRef xx)

    Dim i As Long, j As Long, j1 As Long, j2 As Long
    Dim x1, x2
    For i = 1 To 9 Step 3
        j1 = Int(Rnd() * 3) + i
        j2 = Int(Rnd() * 3) + i
        If j1 = j2 Then Exit Sub
        x1 = Application.Index(xx, j1, 0)
        x2 = Application.Index(xx, j2, 0)
        For j = 1 To 9
            xx(j1, j) = x2(j)
            xx(j2, j) = x1(j)
        Next
    Next
End Sub
Private Function 列ブロックシャッフル(ByVal xx) As Variant
    Dim i As Long, j As Long, j1 As Long, j2 As Long
    Dim x1, x2
    列ブロックシャッフル = xx
    x1 = xx
    j1 = Int(Rnd() * 3) + 1
    j2 = Int(Rnd() * 3) + 1
    If j1 = j2 Then Exit Function
    For i = 1 To 3
        For j = 1 To 9
            x1(j, (j1 - 1) * 3 + i) = xx(j, (j2 - 1) * 3 + i)
        Next
        For j = 1 To 9
            x1(j, (j2 - 1) * 3 + i) = xx(j, (j1 - 1) * 3 + i)
        Next
    Next
    列ブロックシャッフル = x1
End Function

Private Function 行ブロックシャッフル(ByVal xx) As Variant

    Dim i As Long, j As Long, j1 As Long, j2 As Long
    Dim x1
    行ブロックシャッフル = xx
    x1 = xx
    j1 = Int(Rnd() * 3) + 1
    j2 = Int(Rnd() * 3) + 1
    If j1 = j2 Then Exit Function
    For i = 1 To 3
        For j = 1 To 9
            x1((j1 - 1) * 3 + i, j) = xx((j2 - 1) * 3 + i, j)
        Next
        For j = 1 To 9
            x1((j2 - 1) * 3 + i, j) = xx((j1 - 1) * 3 + i, j)
        Next
    Next
    行ブロックシャッフル = x1
End Function

（kazuo） 2020/04/28(火) 07:38

---

SoulManさん、こんにちは。
質問者さんからコメントが無いので、代わってお尋ねします。
数独は、各行、各列ともに、1〜9が一回だけ重複なく登場しないといけないと思いますが、
その条件はどこで反映されているんでしょうか。
結果を拝見すると、それが必ずしも満たされていないようなんですが。
（ γ） 2020/04/29(水) 07:02

---

 おはようございます。
 >数独は、各行、各列ともに、1〜9が一回だけ重複なく登場しないといけないと思いますが、
すみません。そんなルールがあるのですね？？？
わたしゃただただ１〜９が並べばいいのかと思っていました。。。

 もう少し勉強します。ありがとうございます。。。m(__)m 
（SoulMan） 2020/04/29(水) 07:20

---

 ちょっとコードを整理しました。
 ロジックは同じです。

 Sub 問題作成()
     Dim i As Long
     Dim BoxNo As String
     i = 9
     Cells(1, 1).Resize(9, 9).ClearContents
     Application.ScreenUpdating = False
     Do
         BoxNo = Mid("124357689", i, 1)
         If BoxSub(CLng(BoxNo)) = True Then
             i = i - 1
             If i = 0 Then Exit Do
         Else
             i = 9
             Cells(1, 1).Resize(9, 9).ClearContents
         End If
         DoEvents
     Loop
     Application.ScreenUpdating = True
 '    MsgBox "完了"
 End Sub
 Function BoxSub(BoxNo As Long) As Boolean
     Dim i As Long, LC As Long
     Dim R As Long, C As Long
     Dim No As Long
     Dim wNo As String
     Dim w As Range
     Dim Box As Range
     Dim W9 As Boolean
     R = Array(0, 1, 1, 1, 4, 4, 4, 7, 7, 7)(BoxNo)
     C = Array(0, 1, 4, 7, 1, 4, 7, 1, 4, 7)(BoxNo)
     Set Box = Cells(R, C).Resize(3, 3)
     LC = 0
     Do
         Box.ClearContents
         wNo = 順番
         For Each w In Box
            For i = 1 To Len(wNo)
                 No = Val(Mid(wNo, i, 1))
                 If WorksheetFunction.CountIf(w.Resize(9, 1), No) = 0 Then
                 If WorksheetFunction.CountIf(w.Resize(1, 9), No) = 0 Then
                     w.Value = Val(No)
                     wNo = Replace(wNo, CStr(No), "")
                     Exit For
                 End If
                 End If
             Next
         Next
         DoEvents
         If WorksheetFunction.CountBlank(Box) <> 0 Then
             Select Case BoxNo
                 Case 2 To 9: LC = LC + 1: If LC >= 10 Then W9 = False: Exit Do
                 Case 1:                                    W9 = False: Exit Do
             End Select
         Else
             W9 = True
             Exit Do
         End If
     Loop
     BoxSub = W9
 End Function
 Function 順番() As String
     Dim W9   As String
     Dim i As Long
     Dim x As Range, w As Range
     Set x = Cells(1, 21).Resize(9, 1)
     x.Formula = "=rand()"
     x.Value = x.Value
     For i = 1 To 9
         W9 = W9 & WorksheetFunction.Rank(Cells(i, 21), Cells(1, 21).Resize(9, 1))
     Next
     順番 = W9
 End Function

（チオチモリン） 2020/04/29(水) 18:21

---

 既に回答をいただいていますが、乱数に基づき設定する方法をもう一つ。
 少し前の発言で触れたバックトラック法を使った方法を参考までに載せておきます。
 （ロジックは基本的に先だって紹介したサイトのものです）
 コードはやや長いですが、実行時間はたぶん短いです。

 1.標準モジュールにそのままコピーペイストして下さい。
 2.testを実行すると、A1:I9に結果を表示します。
 3.いくつもの完成形を続けて作成する場合には、コードの最初にある
   kosuという定数を修正して下さい。

 =================================================
 Option Explicit

 Const kosu = 1             ' 作成する数独完成形の個数（■■要修正）

 Const N As Long = 9
 Const B As Long = 3
 Dim checkCounter As Long    ' check関数の使用回数（debug用）

 '数独完成形をkaisu個作成
 Sub test()
     Dim board() As Long
     Dim k       As Long
     Dim t
     t = Timer

     'Rnd (-10)      '(1)乱数シードを固定したい場合
     Randomize       '(2)その都度、シードを変える場合

     On Error GoTo success

     For k = 1 To kosu
         checkCounter = 0
         ReDim board(1 To N * N)

         Call check(board, 1)

 success:
         Resume Next
         Call myPrint(board, k)   'シート書き込み
         'Debug.Print checkCounter; "  checkcounter"
     Next

     Debug.Print Timer - t; "  " & kosu & " 個作成済み"
     Debug.Print "-----------------------------------"
 End Sub

 'pos番目のマスに候補を入力する
 Function check(board() As Long, pos&)
     Dim newPos&
     Dim j&, k&
     Dim newValue&

     checkCounter = checkCounter + 1     'このプロシージャの実行回数カウントのため

     If pos = N * N + 1 Then             '完成形となったら
         Err.Raise vbObjectError + 513   '例外のthrow に相当。
     End If

     '未記入セルのうち、一番若いもの
     For k = pos To N * N
         If board(k) = 0 Then
             newPos = k
             Exit For
         End If
     Next

     ReDim randBoard9(1 To N) As Long

     Call rand9(randBoard9)  'シャッフルした1〜9からなる配列の生成

     For j = 1 To N
         newValue = randBoard9(j)
         '縦・横・ボックス内に重なりがないか検証
         If canBePlaced(board, newPos, newValue) Then
             board(newPos) = newValue      'OKなら仮記入
             Call check(board, newPos + 1) '次の未記入セルに対して再帰実行

             Debug.Print newPos; "  backtracking"
             board(newPos) = 0   '■Backtracking（1〜9まで試して不首尾ならワンステップ前に戻る）
         End If
     Next
 End Function

 Function rand9(randomBoard() As Long)    '1〜9の値をランダムにシャッフル
     Dim k&, i&, j&, tmp&

     For k = 1 To N
         randomBoard(k) = k
     Next
     'ランダムにシャッフル
     For i = 1 To N
         'j = Application.RandBetween(1, N)  '乱数シード値のコントロール外のため使用せず
         j = Int(Rnd() * N) + 1
         If i <> j Then
             tmp = randomBoard(i)
             randomBoard(i) = randomBoard(j)
             randomBoard(j) = tmp
         End If
     Next
 End Function

 Function canBePlaced(board() As Long, pos&, v&) As Boolean
     'check関数で仮に入れられた値が、縦・横・その値の所属の3×3マスに
     '既にあれば Falseを返す（なければ Trueを返す)
     Dim r&, c&
     Dim i&, j&, topLeft&
     r = ((pos - 1) \ N) + 1     '   r=行
     c = ((pos - 1) Mod N) + 1   '   c=列

     For i = 1 To N
         If board((r - 1) * N + i) = v Then  '同じ行に同一値があれば
             canBePlaced = False: Exit Function
         End If
         If board(c + (i - 1) * N) = v Then  '同じ列に同一値があれば
             canBePlaced = False: Exit Function
         End If
     Next
     topLeft = N * ((r - 1) \ B) * B + ((c - 1) \ B) * B + 1
     For i = 1 To B
         For j = 1 To B
                                             '3×3ボックス内に同一値があれば
             If board(topLeft + (i - 1) * N + (j - 1)) = v Then
                 canBePlaced = False: Exit Function
             End If
         Next
     Next
     canBePlaced = True
 End Function

 Function myPrint(board() As Long, r As Long)
     Dim k&, j&
     ReDim v(1 To N, 1 To N)
     For k = 1 To N
         For j = 1 To N
             v(k, j) = board((k - 1) * N + j)
         Next
     Next
     'ワークシート書き込み
     Cells((r - 1) * 11 + 1, "A").Resize(N, N).Value = v
 End Function
 =================================================
 結果の書き出しは、各エリアに直接書き込んでいますが、
 書式を整えたA1:I9　にいったん書き込み、その後、コピーペイストすると
 各エリアに書式を設定する手間は省けるかもしれません。

 なお、Err.Raiseの後始末にはResumeを使うとよかったんですね。
 （On Errorを繰り返し使うことはできないんですね。すっかり忘れていました）

 また、元のコードでの乱数シードの使い方と少し変えています。
 私には、頻繁にシード値を変えると却って乱数作成の規則性？が崩れるように
 思えます。
（γ） 2020/04/30(木) 22:25

---

ｃは解らないので、手作業で問題作成補助用としてγさんのプロシージャを利用させていただきました。
vectorのExcelで数独(ナンプレ)を解く解法ツールのようには、難易度は出ませんが、
複数解があるかはすぐに解りますので、併用すると良いのではと思います。

 Const N As Long = 9, B As Long = 3
 Dim flag As Boolean    ' success 確認用

 '数独問題の妥当性チェック
 Sub 妥当性チェック()
    Dim Board() As Long, Dummy() As Long
    Dim k       As Long, kosu   As Long, ans    As Long
    Call 初期化
    kosu = 30   '確率　1-0.5＾29=99.9999998%
    ReDim Dummy(1 To N * N)
    Range("a2:i10,a13:i21").ClearContents
    On Error GoTo success
    For k = 1 To kosu
        boardget Board
        Call check2(Board, 1)
success:
        Resume Next
        If flag Then
            MsgBox "解がありません"
            Exit Sub
        End If
        If hikaku(Board, Dummy) Then
            ans = ans + 1
        End If
        Call myPrint2(Board, ans)
        If 1 < ans Then
            MsgBox "解が複数あります"
            Exit Sub
        End If
        Dummy = Board
    Next
    If MsgBox("盤面を記入しますか？", vbYesNo) = vbYes Then
        Range("A2").Resize(N, N).Copy Range("K13")
        Range("K13").Resize(N, N).Interior.Color = vbYellow
    End If
 End Sub
 Private Sub 初期化()
    Const 解析 = "解析"
    Dim i As Long, j As Long
    Dim sp As Shape
    Randomize
    On Error Resume Next
    Set sp = ActiveSheet.Shapes(解析)
    On Error GoTo 0
    If Not sp Is Nothing Then Exit Sub
    ActiveWindow.DisplayGridlines = False
    Cells.Clear
    Cells.Interior.Color = 13431551
    Rows("1:40").RowHeight = 17.25
    Columns("a:z").ColumnWidth = 2.5
    Range("A1").Value = " 回答１"
    Range("A12").Value = " 回答２"
    Range("K1").Value = "問題入力"
    Range("K12").Value = "盤面"
    With Range("K2").Resize(B, B)
    For i = 0 To N - 1 Step B
        For j = 0 To N - 1 Step B
            .Offset(i, j).BorderAround xlContinuous, xlMedium
            .Offset(i, j).Borders(xlInsideHorizontal).Weight = xlThin
            .Offset(i, j).Borders(xlInsideVertical).Weight = xlThin
        Next
    Next
        .Resize(N, N).BorderAround xlContinuous, xlMedium
    End With
    With Range("K2").Resize(N, N)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .Copy
        Range("A2").PasteSpecial xlPasteFormats
        Range("A13").PasteSpecial xlPasteFormats
        Application.CutCopyMode = False
        .Cells(1).Select
        .Interior.Color = 15921906
        .Offset(0).Resize(B).Value = [{6,0,0,0,3,0,0,0,2;1,7,0,8,0,5,0,0,0;0,0,0,0,7,0,0,0,0}]
        .Offset(3).Resize(B).Value = [{0,8,3,0,0,0,0,4,0;0,0,0,0,0,0,0,0,0;5,0,9,0,0,0,6,0,0}]
        .Offset(6).Resize(B).Value = [{0,9,0,0,4,0,7,8,0;7,0,0,0,5,0,9,1,0;0,0,0,0,0,1,0,3,0}]
        .Replace "0", ""
    End With
    With Range("u2:x3")
        Set sp = .Worksheet.Shapes.AddShape(msoShapeRoundedRectangle, .Left, .Top, .Width, .Height)
        sp.Name = 解析
    End With
    With sp
        .Shadow.Type = msoShadow21
        .OnAction = "妥当性チェック"
        With .TextFrame2
            .VerticalAnchor = msoAnchorMiddle
            With .TextRange
                .Font.Bold = msoTrue
                .Font.Size = 14
                .Text = "解析"
                .ParagraphFormat.Alignment = msoAlignCenter
            End With
        End With
    End With
 End Sub
 Private Function hikaku(Board() As Long, Dummy() As Long) As Boolean
    Dim i As Long
    For i = LBound(Board) To UBound(Board)
        If Board(i) <> Dummy(i) Then
            hikaku = True
            Exit For
        End If
    Next
 End Function
 Private Sub boardget(Board() As Long)
    Dim r As Range
    Dim i As Long, ans As Long
    ReDim Board(1 To N * N)
    For Each r In Worksheets(1).Range("K2").Resize(N, N)
        i = i + 1
        ans = Val(r.Value)
        If ans < 1 Or 9 < ans Then
            ans = 0
            r.ClearContents
        End If
        Board(i) = ans
    Next
 End Sub
 Function check2(Board() As Long, pos As Long)
    Dim newPos  As Long
    Dim j As Long, k As Long
    Dim newValue As Long
    flag = False
    If pos = N * N + 1 Then
        Err.Raise vbObjectError + 513
    End If
    For k = pos To N * N
        If Board(k) = 0 Then
            newPos = k
            Exit For
        End If
    Next
    ReDim randBoard9(1 To N) As Long
    Call rand9(randBoard9)
    For j = 1 To N
        newValue = randBoard9(j)
        If canBePlaced(Board, newPos, newValue) Then
            Board(newPos) = newValue
            Call check2(Board, newPos + 1)
            Board(newPos) = 0
        End If
    Next
    flag = True
 End Function
 Private Function myPrint2(Board() As Long, r As Long)
     Dim k As Long, j As Long
     ReDim v(1 To N, 1 To N)
     For k = 1 To N
         For j = 1 To N
             v(k, j) = Board((k - 1) * N + j)
         Next
     Next
     Cells((r - 1) * 11 + 2, "A").Resize(N, N).Value = v
 End Function

 Private Function rand9(randomBoard() As Long)    '1〜9の値をランダムにシャッフル
     Dim k As Long, i As Long, j As Long, tmp As Long
     For k = 1 To N
         randomBoard(k) = k
     Next
     'ランダムにシャッフル
     For i = 1 To N
         j = Int(Rnd() * N) + 1
         If i <> j Then
             tmp = randomBoard(i)
             randomBoard(i) = randomBoard(j)
             randomBoard(j) = tmp
         End If
     Next
 End Function

 Private Function canBePlaced(Board() As Long, pos&, v&) As Boolean
     'check関数で仮に入れられた値が、縦・横・その値の所属の3×3マスに
     '既にあれば Falseを返す（なければ Trueを返す)
     Dim r As Long, c As Long
     Dim i As Long, j As Long, topLeft As Long
     r = ((pos - 1) \ N) + 1     '   r=行
     c = ((pos - 1) Mod N) + 1   '   c=列
     For i = 1 To N
         If Board((r - 1) * N + i) = v Then  '同じ行に同一値があれば
             canBePlaced = False: Exit Function
         End If
         If Board(c + (i - 1) * N) = v Then  '同じ列に同一値があれば
             canBePlaced = False: Exit Function
         End If
     Next
     topLeft = N * ((r - 1) \ B) * B + ((c - 1) \ B) * B + 1
     For i = 1 To B
         For j = 1 To B
                                             '3×3ボックス内に同一値があれば
             If Board(topLeft + (i - 1) * N + (j - 1)) = v Then
                 canBePlaced = False: Exit Function
             End If
         Next
     Next
     canBePlaced = True
 End Function

（kazuo） 2020/05/02(土) 19:15

---

 こんばんは。ちょっと書こうかどうか迷ったのですが、

 γさんの On Error ステートメントの使い方に非常に違和感を感じます。

 Resume ステートメントはエラー処理ルーチンの中で使うべきもので、
 通常の処理の中で使うものではないかと思います。

 今回の例では、　 
 ・Errorが発生したとき、successに飛ぶ
 ・Resume Next が実行されるため、エラー発生行の次の行にとぶ
 ・Resume Next が実行される(なにもおこらないけど．．．)

  と、Resume Nextで戻った先がResume Nextで、
　都合2回 Resume Next が実行されるのが私の違和感の元です。
　これで問題なく動いてるでしょといわれれば、言葉がないですが、

  素直に On Error Resume Next で処理すべきかと思います。

    For k = 1 To kosu
        checkCounter = 0
        ReDim board(1 To N * N)
        On Error Resume Next
           Call check(board, 1)
           flgSucccess = Err.Number
        On Error Goto 0
        If flgSucccess = bObjectError + 513 Then Call myPrint(board, k)   'シート書き込み
    Next
（´・ω・`） 2020/05/02(土) 21:14

---

 （´・ω・`）さん、ありがとうございました。
 On Error Resume Nextの機能をよく理解していなかったようです。
 (ヘルプ引用）
 | On Error Resume Next ステートメントは、
 | 実行時エラーを発生させたステートメントの直後にあるステートメント、
 | または On Error Resume Next ステートメントを含むプロシージャから最後に呼び出しを行った直後のステートメントを使って、
 | 実行を継続します。
 私は、どうやら前者のイメージしか持っていなかったので、checkをすべてたためないだろうと思っていました。
 助かりました。
（γ） 2020/05/02(土) 23:19

---

 On Error Resume Nextは、1か所で十分？

 On Error Resume Next
 For i = 1 To 10
    ans = 1 / 0
    If Err Then
       Err.Clear
    End If
 Next
 MsgBox i
（BJ） 2020/05/02(土) 23:42

---

 >On Error Resume Nextは、1か所で十分？
 そうですね。
 Err.Clearを使った方がいいですね。
 Microsoftのサイトにもそのような例が示されています。 
https://docs.microsoft.com/ja-jp/office/vba/language/reference/user-interface-help/clear-method-visual-basic-for-applications

 個人的な好みでというかクセで
 On Error は、できるだけピンポイントに仕掛けたいので、
 今回このように書きました。　 
 ただ、ループの中にいれて On Error Resume Next と On Error Goto 0 を
 繰り返すと処無駄な理コストがかかっちゃいますね。
（´・ω・`） 2020/05/03(日) 05:58

---

お二方ありがとうございます。
On Error Resume Nextの使用範囲限定は同感で、よく回答コメントで申し上げることが多いです。
ただ今回の場合は、それ以外にさほどの処理がないので、より広くてもよかったかもしれません。
Err.Clearは最初に使っていたのですが、何分、On Error Goto Successとの組み合わせだと、
Err.Raise XXXでエラーになるというのが（私にとっての）出発点でした。

Excel vba 関数機能別一覧表 :
https://www.ceodata.com/excel-functions/

（γ） 2020/05/03(日) 10:37

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.