Es evidente que el programa NO RESUELVE un sudoku, lo cual me parece bien, pues para resolverlo, cada uno debe poder hacerlo y asi ejercitarse, ademas que terminarlo es bastante gratificante, aunque debe serlo tambien realizar un code que haga que el propio ordenador lo haga por nosotros. En fin gusto de cada uno, en mi caso prefiero resolverlo manualmente.
Bueno, sin mas, aquí el código para quien le sirva:
Código:
Option Explicit
'9 filas x 9 columnas
Dim Sud(1 To 9, 1 To 9) As Byte
Private Sub CMDLLenar_Click()
Dim f As Byte
Dim c As Byte
'cargamos el SUDOKU con sus valores originales FIJOS
Sud(1, 2) = 9
Sud(1, 4) = 6
Sud(1, 6) = 5
Sud(2, 7) = 8
Sud(2, 9) = 1
Sud(3, 1) = 2
Sud(3, 5) = 3
Sud(3, 8) = 6
Sud(4, 1) = 3
Sud(4, 2) = 8
Sud(4, 5) = 9
Sud(6, 5) = 1
Sud(6, 8) = 2
Sud(6, 9) = 7
Sud(7, 2) = 1
Sud(7, 5) = 8
Sud(7, 9) = 9
Sud(8, 1) = 6
Sud(8, 3) = 4
Sud(9, 4) = 2
Sud(9, 6) = 7
Sud(9, 8) = 5
'visualizamos el array en el Hierarchical
For c = 1 To 9
For f = 1 To 9
If Sud(f, c) <> 0 Then
Colocar f, c, Sud(f, c)
End If
Next
Next
'coloreamos de rojo los numeros fijos para diferenciarlos de los candidatos
Dim fila1 As Integer
Dim columna1 As Integer
With H1
' Recorre las filas
For fila1 = 0 To 8
For columna1 = 0 To 8
.Row = fila1
.Col = columna1
If Val(.Text) > 0 Then
.CellForeColor = &HFF& 'rojooo
End If
Next
Next
'coloreamos algunas regiones para diferenciar
For fila1 = 0 To 2
For columna1 = 0 To 2
.Row = fila1
.Col = columna1
.CellBackColor = RGB(127, 220, 98)
Next
Next
For fila1 = 3 To 5
For columna1 = 3 To 5
.Row = fila1
.Col = columna1
.CellBackColor = RGB(127, 123, 208)
Next
Next
For fila1 = 6 To 8
For columna1 = 6 To 8
.Row = fila1
.Col = columna1
.CellBackColor = RGB(247, 123, 198)
Next
Next
For fila1 = 0 To 2
For columna1 = 6 To 8
.Row = fila1
.Col = columna1
.CellBackColor = RGB(247, 220, 198)
Next
Next
For fila1 = 6 To 8
For columna1 = 0 To 2
.Row = fila1
.Col = columna1
.CellBackColor = RGB(47, 220, 198)
Next
Next
End With
End Sub
Private Sub Command1_Click()
'///////////// Iniciamos a visualizar los candidatos ///////////
Dim Candidatos As Byte
Dim Casas As Byte '9 regiones o casas
For Casas = 1 To 9 'buscaremos los candidatos en las 9 casas o regiones
For Candidatos = 1 To 9
BuscarCandidatos Casas, Candidatos 'buscamos los candidatos posibles en las 9 casas
Next
Next
End Sub
'Funcion que busca un valor en la fila indicada
Private Function BuscarFila(Fila As Byte, ValorBuscado As Byte)
Dim c As Byte
For c = 1 To 9
If Sud(Fila, c) = ValorBuscado Then
BuscarFila = True
Exit Function
Else
BuscarFila = False
End If
Next
End Function
'Funcion que busca un valor en la columna indicada
Private Function BuscarColumna(Columna As Byte, ValorBuscado As Byte)
Dim f As Byte
For f = 1 To 9
If Sud(f, Columna) = ValorBuscado Then
BuscarColumna = True
Exit Function
Else
BuscarColumna = False
End If
Next
End Function
'Funcion que nos dice si un valor indicado existe o no en una region o casa indicada
Function Encontrar(Casa As Byte, Valor As Byte) As Boolean
Dim f As Byte, c As Byte
If Casa = 1 Then 'quiere decir que se va a buscar en la casa 1
For f = 1 To 3 'busqueda por filas
For c = 1 To 3
If Sud(f, c) = Valor Then
Encontrar = True
Exit Function
End If
Next
Next
End If
If Casa = 2 Then 'quiere decir que se va a buscar en la casa 2
For f = 1 To 3 'busqueda por filas
For c = 4 To 6
If Sud(f, c) = Valor Then
Encontrar = True
Exit Function
End If
Next
Next
End If
If Casa = 3 Then 'quiere decir que se va a buscar en la casa 3
For f = 1 To 3 'busqueda por filas
For c = 7 To 9
If Sud(f, c) = Valor Then
Encontrar = True
Exit Function
End If
Next
Next
End If
If Casa = 4 Then
For f = 4 To 6 'busqueda por filas
For c = 1 To 3
If Sud(f, c) = Valor Then
Encontrar = True
Exit Function
End If
Next
Next
End If
If Casa = 5 Then
For f = 4 To 6 'busqueda por filas
For c = 4 To 6
If Sud(f, c) = Valor Then
Encontrar = True
Exit Function
End If
Next
Next
End If
If Casa = 6 Then
For f = 4 To 6 'busqueda por filas
For c = 7 To 9
If Sud(f, c) = Valor Then
Encontrar = True
Exit Function
End If
Next
Next
End If
If Casa = 7 Then
For f = 7 To 9 'busqueda por filas
For c = 1 To 3
If Sud(f, c) = Valor Then
Encontrar = True
Exit Function
End If
Next
Next
End If
If Casa = 8 Then
For f = 7 To 9 'busqueda por filas
For c = 4 To 6
If Sud(f, c) = Valor Then
Encontrar = True
Exit Function
End If
Next
Next
End If
If Casa = 9 Then
For f = 7 To 9 'busqueda por filas
For c = 7 To 9
If Sud(f, c) = Valor Then
Encontrar = True
Exit Function
End If
Next
Next
End If
End Function
'procedimiento que simplemente coloca un valor en el Flex Grid
Private Sub Colocar(Fila As Byte, Columna As Byte, Valor As Byte)
Dim a As Byte, b As Byte
Dim fila1 As Integer
With H1
.TextMatrix(Fila - 1, Columna - 1) = .TextMatrix(Fila - 1, Columna - 1) & Valor
End With
End Sub
'iniciamos la busqueda de candidatos
Private Sub BuscarCandidatos(Casa As Byte, ValorBuscadoEnLaCasa As Byte)
Dim f1 As Byte
Dim f2 As Byte
Dim c1 As Byte
Dim c2 As Byte
'establemos las coordenadas para cada region o casa
Select Case Casa
Case 1:
f1 = 1
f2 = 3
c1 = 1
c2 = 3
Case 2:
f1 = 1
f2 = 3
c1 = 4
c2 = 6
Case 3:
f1 = 1
f2 = 3
c1 = 7
c2 = 9
Case 4:
f1 = 4
f2 = 6
c1 = 1
c2 = 3
Case 5:
f1 = 4
f2 = 6
c1 = 4
c2 = 6
Case 6:
f1 = 4
f2 = 6
c1 = 7
c2 = 9
Case 7:
f1 = 7
f2 = 9
c1 = 1
c2 = 3
Case 8:
f1 = 7
f2 = 9
c1 = 4
c2 = 6
Case 9:
f1 = 7
f2 = 9
c1 = 7
c2 = 9
End Select
Dim f As Byte
Dim c As Byte
If Encontrar(Casa, ValorBuscadoEnLaCasa) = False Then 'si el valor buscado no es un numero FIJO
For f = f1 To f2 'busqueda por filas
For c = c1 To c2
If Sud(f, c) = 0 Then 'si esta vacio entonces alli debemos poner un candidato
'para que sea candidato, no debe estar ni en la fila ni en la columna (mucho menos en la region o casa)
If BuscarFila(f, ValorBuscadoEnLaCasa) = False And BuscarColumna(c, ValorBuscadoEnLaCasa) = False Then
Colocar f, c, ValorBuscadoEnLaCasa 'de ser asi entonces se considera como candidato
End If
End If
Next
Next
End If
End Sub
Private Sub Form_Load()
Dim f As Byte, c As Byte
For f = 0 To 8
H1.RowHeight(f) = 700
Next
For f = 0 To 8
H1.ColWidth(f) = 700
Next
End Sub
El sudoku propuesto: (Boton Iniciar Sudoku)
El sudoku propuesto con todos sus candidatos: (Boton Encontrar Candidatos)