Results of 1 - 1 of about 37681 for IF (0.008 sec.)
- [[20200426185317]]
- #score: 1591
- @digest: 6c1aa0ff48795836265f6c85db3ef908
- @id: 83274
- @mdate: 2020-12-09T08:17:21Z
- @size: 37613
- @type: text/plain
- #keywords: canbeplaced (95950), randomboard (88570), 数独 (77311), newpos (64259), boxno (60898), checkcounter (50119), board (38681), newvalue (35713), success (29404), ッフ (27722), myscs (27040), ャッ (23521), シャ (19258), xlmedium (16330), フル (14077), 乱数 (11552), 成形 (10477), function (8904), ブロ (6672), xx (6418), long (5246), 候補 (4888), resize (4831), resume (4631), borders (4421), ダム (4388), worksheetfunction (4005), next (3931), mya (3690), 完成 (3586), boolean (3308), error (3307)
- 『数独・ナンプレの解答をランダムで作りたい』（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に作成された組み合わせを ランダムに数値シャッフル、列シャッフル、行シャッフルして、10行ずつずらし表示します。 ランダムですのでシャッフルされない場合もあります。 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 ' VBAによるメルセンヌツイスタ ' システムを起動してからの時間をミリ秒単位で返す ' 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個）に1〜9が重複無く配置されているかをチェック） などくらいです。 ちなみに、自分の学習を兼ねて、VBAとは別の言語で書いてみましたら、 1000個の数独パターンを 0.8秒くらいで作成できました。 ちなみに、バックトラック法を用いると、この場合、行き止まりになった再帰処理が 積み重なっていくわけですが、正解にたどり着いた段階で、それらの閉じられていない プロシージャをなんらかの手段で閉じる必要があります。 記事にあるC言語のコードでは、try catch構文を使用して対応しています。 （つまり、9×9の完成形に達したら、例外を投げて大域的ジャンプをしています。 これで、同時に関数スタックがすべてクリアーされるわけです。） ところが、VBAにはこうした機構が無いので立ち往生します。 普通は、On error と Err.Raiseの意図的発生とを組み合わせるんでしょうが、 この場合は複数回繰り返すと、一回目の数独作成は成功しますが、 二度目のErr.Raiseの意図的発生で不可解なエラーが起きてしまい、 なんとも解決できない状況です。これは困ったなあ、という感じです。 愚痴になりましたのでこの辺で。 （ γ） 2020/04/27(月) 23:13 ---- 質問の趣旨とは異なりますが、 γさんの説明でお気づきでしょうが、数独問題は完成盤面としては一通りだけ有れば良いのです。 それよりも見た目は除きますが、無駄な公開マスを少なくし、回答が唯一になるように作るのが大切です。 1.数字の入れ替え x362880 2.90度回転 x2 3.ブロック入れ替え x6 4.行列入れ替え x36 プロシージャ名をアレンジとし、理論的には1回のアレンジで4.が36通りからになるようにし、3.を追加しました。 但し、2.は除いてあります。 ですので、1つの問題でアレンジすることにより、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が一回だけ重複なく登場しないといけないと思いますが、 すみません。そんなルールがあるのですね??? わたしゃただただ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 ---- cは解らないので、手作業で問題作成補助用としてγさんのプロシージャを利用させていただきました。 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 = " 回答1" Range("A12").Value = " 回答2" 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... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/202004/20200426185317.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97038 documents and 608190 words.
訪問者：