Sudoku lösen
15.12.2005 12:20:41
Reinhard
Hi Frank,
wie gesagt, nur 2 mal getestet, da klappte es.
https://www.herber.de/bbs/user/29321.xls
Nachfolgend der Code, die Vorgaben werden in A1:I9 erwartet.
An sich bietet sich da an so was rekursives zu benutzen, das schaffte ich aber nicht zu kodieren.
Gruß
Reinhard
ps:Das Forum lebt auch von Rückmeldungen
Option Explicit
Option Base 1
Dim k(9, 9) As String
Sub sudoku()
Dim Zelle As Range
For Each Zelle In Range("A1:I9")
Zelle.Font.Bold = Not Zelle.Value = ""
Next Zelle
Range("J10:R18").Font.Bold = False
Range("A1:I9").Copy Destination:=Range("J10")
Call Zahlenmoeglichkeiten
Call Zeilencheck
Call Spaltencheck
Call Quadratcheck
Call Zeilencheck
Call Spaltencheck
Call Quadratcheck
Call Zeilencheck
Call Spaltencheck
Call Quadratcheck
Call Ausgabe
End Sub
Sub Zahlenmoeglichkeiten()
Dim z As Byte, s As Byte
For z = 1 To 9
For s = 1 To 9
k(z, s) = "123456789"
If Cells(z, s) <> "" Then k(z, s) = Right(Str(Cells(z, s)), 1)
Next s
Next z
End Sub
Sub Zeilencheck()
Dim z As Byte, s As Byte, n As Byte, pos As Byte
For z = 1 To 9
For s = 1 To 9
If Len(k(z, s)) = 1 Then
For n = 1 To 9
If n <> s Then
pos = InStr(k(z, n), k(z, s))
If pos <> 0 Then k(z, n) = Left(k(z, n), pos - 1) & Mid(k(z, n), pos + 1)
End If
Next n
End If
Next s
Next z
End Sub
Sub Spaltencheck()
Dim z As Byte, s As Byte, n As Byte, pos As Byte
For s = 1 To 9
For z = 1 To 9
If Len(k(z, s)) = 1 Then
For n = 1 To 9
If n <> z Then
pos = InStr(k(n, s), k(z, s))
If pos <> 0 Then k(n, s) = Left(k(n, s), pos - 1) & Mid(k(n, s), pos + 1)
End If
Next n
End If
Next z
Next s
End Sub
Sub Quadratcheck()
Dim z As Byte, s As Byte, pos As Byte
Dim ze As Byte, sp As Byte, a As Byte, b As Byte
For z = 1 To 9
For s = 1 To 9
If Len(k(z, s)) = 1 Then
ze = Int((z - 1) / 3) * 3 + 1 'Ermittlung oberste Zeile des Quadrast
sp = Int((s - 1) / 3) * 3 + 1 'Ermittlung linkeste Spalte des Quadrast
For a = 0 To 2 'Offset auf oberste Zeile des Quadrats
For b = 0 To 2 'Offset auf linkeste Spalte des Quadrats
If (ze + a) <> z Or (sp + b) <> s Then
pos = InStr(k(ze + a, sp + b), k(z, s))
If pos <> 0 Then k(ze + a, sp + b) = Left(k(ze + a, sp + b), pos - 1) & Mid(k(ze + a, sp + b), pos + 1)
End If
Next b
Next a
End If
Next s
Next z
End Sub
Sub Ausgabe()
Dim z As Byte, s As Byte
For z = 1 To 9
For s = 1 To 9
Cells(9 + z, 9 + s) = k(z, s)
Next s
Next z
End Sub