Sub SolveSudoku()
Dim r As Integer, c As Integer

' ナンプレ問題を読み取る
For r = 1 To 9
For c = 1 To 9
Board(r, c) = Cells(r, c).Value
Next c
Next r

' 解く
If Solve(1, 1) Then
' 結果を出力
For r = 1 To 9
For c = 1 To 9
Cells(r, c + 10).Value = Board(r, c)
Next c
Next r
MsgBox "ナンプレが解けました！", vbInformation
Else
MsgBox "解ける解答が見つかりませんでした。", vbExclamation
End If
End Sub

Function Solve(row As Integer, col As Integer) As Boolean
If row > 9 Then
Solve = True
Exit Function
End If

Dim nextRow As Integer, nextCol As Integer
nextRow = row + (col \ 9)
nextCol = (col Mod 9) + 1

If Board(row, col) <> 0 Then
Solve = Solve(nextRow, nextCol)
Else
Dim num As Integer
For num = 1 To 9
If IsValid(row, col, num) Then
Board(row, col) = num
If Solve(nextRow, nextCol) Then
Solve = True
Exit Function
End If
Board(row, col) = 0
End If
Next num
Solve = False
End If
End Function

Function IsValid(row As Integer, col As Integer, num As Integer) As Boolean
Dim i As Integer, j As Integer

' 行と列のチェック
For i = 1 To 9
If Board(row, i) = num Or Board(i, col) = num Then
IsValid = False
Exit Function
End If
Next i

' 3x3 グリッドのチェック
Dim startRow As Integer, startCol As Integer
startRow = ((row - 1) \ 3) * 3 + 1
startCol = ((col - 1) \ 3) * 3 + 1

For i = 0 To 2
For j = 0 To 2
If Board(startRow + i, startCol + j) = num Then
IsValid = False
Exit Function
End If
Next j
Next i

IsValid = True
End Function

=== ここまでです =====

2024-11-03

ChatGPT_ナンプレを解くマクロ作成　（ CODE )

ナンプレを解くマクロです

ChatGPT で CODE を作りました

下記の動画内で Excel のマクロへの登録方法を説明しています

【動画のタイトル】

ChatGPT マクロ生成ナンプレを解析

【Ｕ．Ｒ．Ｌ．】

https://youtu.be/x9M_xiTiGew

**** CODE ( ここから )*******

Option Explicit

Sub SolveSudoku()
Dim row As Integer, col As Integer
If Solve(1, 1) Then
MsgBox "ナンプレが解けました！", vbInformation
Else
MsgBox "解決策が見つかりませんでした。", vbExclamation
End If
End Sub

Function Solve(row As Integer, col As Integer) As Boolean
Dim nextRow As Integer, nextCol As Integer
If row = 10 Then
Solve = True
Exit Function
End If

If col = 9 Then
nextRow = row + 1
nextCol = 1
Else
nextRow = row
nextCol = col + 1
End If

If Cells(row, col).Value <> "" Then
Solve = Solve(nextRow, nextCol)
Exit Function
End If

Dim num As Integer
For num = 1 To 9
If IsValid(row, col, num) Then
Cells(row, col).Value = num
If Solve(nextRow, nextCol) Then
Solve = True
Exit Function
End If
Cells(row, col).Value = ""
End If
Next num

Solve = False
End Function

Function IsValid(row As Integer, col As Integer, num As Integer) As Boolean
Dim i As Integer, j As Integer
' 行と列の確認
For i = 1 To 9
If Cells(row, i).Value = num Or Cells(i, col).Value = num Then
IsValid = False
Exit Function
End If
Next i

' 3x3のブロックの確認
Dim startRow As Integer, startCol As Integer
startRow = ((row - 1) \ 3) * 3 + 1
startCol = ((col - 1) \ 3) * 3 + 1
For i = 0 To 2
For j = 0 To 2
If Cells(startRow + i, startCol + j).Value = num Then
IsValid = False
Exit Function
End If
Next j
Next i

IsValid = True
End Function

********* EOF ( CODE はここで終わりです )*********