.
Optimise varias cosas...
[opcional]
El siguiente codigo requiere de un form con varios textbox llamados
txtCell (matrix de controles) y un boton llamado
cmdSolve, pongo en descarga el archivo para bajar.
[/opcional]
'
' /////////////////////////////////////////////////////////////
' // Autor: BlackZeroX ( Ortega Avila Miguel Angel ) //
' // //
' // Web: http://InfrAngeluX.Sytes.Net/ //
' // //
' // |-> Pueden Distribuir Este codigo siempre y cuando //
' // no se eliminen los creditos originales de este codigo //
' // No importando que sea modificado/editado o engrandecido //
' // o achicado, si es en base a este codigo //
' /////////////////////////////////////////////////////////////
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim bSudoku(8, 8) As Byte ' // (nColumnas, nFilas)
'Private Sub cmdSolve_Click()
' fillSudoku bSudoku
' Caption = solveSudoku(bSudoku, 0, 0) ' // Por BackTracking
' showSudoku bSudoku
'End Sub
Private Sub Form_Load()
bSudoku(0, 0) = 5
bSudoku(0, 1) = 3
bSudoku(0, 4) = 7
bSudoku(1, 0) = 6
bSudoku(1, 3) = 1
bSudoku(1, 4) = 9
bSudoku(1, 5) = 5
bSudoku(2, 1) = 9
bSudoku(2, 2) = 6
bSudoku(2, 7) = 1
bSudoku(3, 0) = 8
bSudoku(3, 4) = 6
bSudoku(3, 8) = 3
bSudoku(4, 0) = 4
bSudoku(4, 3) = 8
bSudoku(4, 5) = 3
bSudoku(4, 8) = 1
bSudoku(5, 0) = 7
bSudoku(5, 4) = 2
bSudoku(5, 8) = 6
bSudoku(6, 1) = 6
bSudoku(6, 6) = 2
bSudoku(6, 7) = 8
bSudoku(7, 3) = 4
bSudoku(7, 4) = 1
bSudoku(7, 5) = 9
bSudoku(7, 8) = 5
bSudoku(8, 4) = 8
bSudoku(8, 7) = 7
bSudoku(8, 8) = 9
Debug.Print "Matrix inicial."
showSudoku bSudoku
If solveSudoku(bSudoku, 0, 0) Then
Debug.Print "Sudoku Resuelto"
showSudoku bSudoku
Else
Debug.Print "No se puede resolver, revisa la matrix."
End If
End Sub
Public Sub showSudoku(ByRef bArray() As Byte)
Dim i As Integer
Dim j As Integer
Show
For i = 0 To UBound(bArray, 1) ' // Fila
For j = 0 To UBound(bArray, 2) ' // Columa
'txtCell((i * 9) + j).Text = bArray(j, i)
If (((j + &H1) Mod &H3) = &H0) Then
Debug.Print bArray(j, i); "|";
Else
Debug.Print bArray(j, i);
End If
Next
Debug.Print
If (((i + &H1) Mod &H3) = &H0) Then Debug.Print String(32, "-")
Next
End Sub
'Public Sub fillSudoku(ByRef bArray() As Byte)
'Dim i As Integer
'Dim j As Integer
' Show
' For i = 0 To UBound(bArray, 1) ' // Fila
' For j = 0 To UBound(bArray, 2) ' // Columa
' bArray(j, i) = txtCell((i * 9) + j).Text
' Next
' Next
'End Sub
Public Function chkRow(ByRef bArray() As Byte, ByVal lIndex As Long, ByVal lVal As Long) As Boolean
' // Revisa la existencia de lVal en una Fila (lIndex).
Dim i As Long
Do While (i < 8) And (chkRow = False)
If (bArray(i, lIndex) = lVal) Then chkRow = True
i = (i + &H1)
Loop
End Function
Public Function chkCol(ByRef bArray() As Byte, ByVal lIndex As Long, ByVal lVal As Long) As Boolean
' // Revisa la existencia de lVal en una Columna (lIndex).
Dim i As Long
Do While (i < 8) And (chkCol = False)
If (bArray(lIndex, i) = lVal) Then chkCol = True
i = (i + &H1)
Loop
End Function
Public Function chkRect(ByRef bArray() As Byte, ByVal lCol As Long, ByVal lRow As Long, ByVal lVal As Long) As Boolean
' // Revisa la existencia de lVal en el cuadrante desde la celda superior izquierda respectiva dados por (lCol, lRow).
Dim i As Long
Dim j As Long
' // Obtenemos los indices de la celda superior izquierda del cuadrante inicial respectivo.
lRow = ((lRow \ 3) * 3)
lCol = ((lCol \ 3) * 3)
Do ' // Filas
j = &H0
Do ' // Columnas
If (bArray(lCol + j, lRow + i) = lVal) Then chkRect = True
j = (j + &H1)
Loop While (j < &H3) And (chkRect = False)
i = (i + &H1)
Loop While (i < &H3) And (chkRect = False)
End Function
Public Function solveSudoku(ByRef bArray() As Byte, ByVal lCol As Long, ByVal lRow As Long) As Boolean
' // Resuelve una Matrix de Sudoku de 9x9 celdas.
' // Si se retorna true, entonces la matrix ya esta Completa y/o Resuelta.
Dim lVal As Long
Dim i As Long
' // Termino de filas.
If (lRow >= 9) Then solveSudoku = True: Exit Function
' // Nos posicionamos en la 1ra celda de lRow vacia (con valor 0).
Do While Not (bArray(lCol, lRow) = &H0) And (solveSudoku = False)
lCol = (lCol + &H1)
If (lCol = &H9) Then
lCol = &H0
lRow = (lRow + &H1)
If (lRow >= &H8) Then solveSudoku = True
End If
Loop
' // Recorremos TODOS LOS VALORES desde 1 a 9 para la celda (lCol, lRow).
For lVal = 1 To 9
If Not chkRect(bArray, lCol, lRow, lVal) Then ' // Cuadro de 3x3.
If Not (chkRow(bArray, lRow, lVal)) Then ' // Fila.
If Not (chkCol(bArray, lCol, lVal)) Then ' // Columnas.
bArray(lCol, lRow) = lVal
If (lCol < 8) Then ' // Aun no llegamos al final de la fila?
solveSudoku = solveSudoku(bArray, (lCol + 1), lRow)
Else ' // Iniciamos otra llamada si mismo pero en la siguiente fila
solveSudoku = solveSudoku(bArray, 0, (lRow + 1))
End If
If Not solveSudoku Then bArray(lCol, lRow) = 0 ' // Seteamos la celda a 0 para realizar el BackTracking.
End If
End If
End If
Next
End Function
output:
Matrix inicial.
5 6 0 | 8 4 7 | 0 0 0 |
3 0 9 | 0 0 0 | 6 0 0 |
0 0 6 | 0 0 0 | 0 0 0 |
--------------------------------
0 1 0 | 0 8 0 | 0 4 0 |
7 9 0 | 6 0 2 | 0 1 8 |
0 5 0 | 0 3 0 | 0 9 0 |
--------------------------------
0 0 0 | 0 0 0 | 2 0 0 |
0 0 1 | 0 0 0 | 8 0 7 |
0 0 0 | 3 1 6 | 0 5 9 |
--------------------------------
No se puede resolver, revisa la matrix.
con la matrix:
bSudoku(5, 0) = 5
bSudoku(6, 0) = 2
bSudoku(1, 1) = 6
bSudoku(2, 1) = 5
bSudoku(4, 1) = 3
bSudoku(0, 2) = 9
bSudoku(1, 2) = 3
bSudoku(5, 2) = 1
bSudoku(1, 3) = 9
bSudoku(3, 3) = 4
bSudoku(4, 3) = 6
bSudoku(5, 3) = 3
bSudoku(8, 4) = 8
bSudoku(1, 5) = 7
bSudoku(3, 5) = 8
bSudoku(6, 5) = 6
bSudoku(1, 6) = 8
bSudoku(3, 6) = 1
bSudoku(7, 6) = 3
bSudoku(8, 6) = 2
bSudoku(4, 7) = 8
bSudoku(8, 7) = 4
bSudoku(0, 8) = 5
bSudoku(4, 8) = 9
Output:
Matrix inicial.
0 0 0 | 0 0 5 | 2 0 0 |
0 6 5 | 0 3 0 | 0 0 0 |
9 3 0 | 0 0 1 | 0 0 0 |
--------------------------------
0 9 0 | 4 6 3 | 0 0 0 |
0 0 0 | 0 0 0 | 0 0 8 |
0 7 0 | 8 0 0 | 6 0 0 |
--------------------------------
0 8 0 | 1 0 0 | 0 3 2 |
0 0 0 | 0 8 0 | 0 0 4 |
5 0 0 | 0 9 0 | 0 0 0 |
--------------------------------
Sudoku Resuelto
1 4 8 | 6 7 5 | 2 9 3 |
2 6 5 | 9 3 8 | 4 1 7 |
9 3 7 | 2 4 1 | 8 5 6 |
--------------------------------
8 9 2 | 4 6 3 | 1 7 5 |
4 5 6 | 7 1 9 | 3 2 8 |
3 7 1 | 8 5 2 | 6 4 9 |
--------------------------------
6 8 9 | 1 2 7 | 5 3 2 |
7 1 3 | 5 8 4 | 9 6 4 |
5 2 4 | 3 9 6 | 7 8 1 |
--------------------------------
Temibles Lunas!¡.
Autor
aun no e encontrado adonde esta el error si existe ya me estoy quedando ciego 
lo que si me di cuenta es 
( o mi programa tambien esta malo 
En línea
