Hallo,
wenn man Sudokus löst und auf einmal festhängt kann es ja hilfreich sein, die bisherigen gefundenen Zahlen anhand der Lösung zu prüfen ob denn da nicht schon ein Fehler ist und das ggfs. korigieren.
Ich habe das Makro an ca. 30 Sudokus getestet und es funktionierte perfekt, was natürlich kein Beweis ist dass es alle Sudokus lösen kann und mir ist auch sehr unklar geblieben ob es für ein Sudoku mehrere Lösungen geben könnte.
Das Makro erwartet die Sudoku Zahlen in Tabelle1 im Bereich „A1:I9“ und präsentiert die Lösung in Tabelle2 „A1:I9“.
Gruß
Reinhard
Option Explicit
Sub sudo()
Dim ws1 As Worksheet, z As Byte, s As Byte, m(9, 9) As String, n As Byte
Dim zq As Byte, sq As Byte, Zelle, Wert As String, neu As Boolean
On Error Resume Next 'wegen Fehler bei CountIf wenn nichts gefunden wird
Set ws1 = Worksheets("Tabelle1")
With Worksheets("Tabelle2")
ws1.Range("A1:I9").Copy Destination:=.Range("A1")
For z = 1 To 9
For s = 1 To 9
If .Cells(z, s) = "" Then
m(z, s) = "123456789"
Else
m(z, s) = .Cells(z, s)
End If
Next s
Next z
End With
nochmal:
With Worksheets("Tabelle2")
For z = 1 To 9 'waagrechte Prüfung
For s = 1 To 9
If Len(.Cells(z, s)) 1 Then
For n = 1 To 9
If Application.WorksheetFunction.CountIf(.Range(.Cells(z, 1), .Cells(z, 9)), CStr(n)) \> 0 Then
m(z, s) = Replace(m(z, s), CStr(n), "")
If Len(m(z, s)) = 1 Then
.Cells(z, s) = m(z, s)
GoTo nochmal
End If
End If
Next n
End If
Next s
Next z
For s = 1 To 9 'senkrechte Prüfung
For z = 1 To 9
If Len(m(z, s)) \> 1 Then
For n = 1 To 9
If Application.WorksheetFunction.CountIf(.Range(.Cells(1, s), .Cells(9, s)), CStr(n)) \> 0 Then
m(z, s) = Replace(m(z, s), CStr(n), "")
If Len(m(z, s)) = 1 Then
.Cells(z, s) = m(z, s)
GoTo nochmal
End If
End If
Next n
Else
m(z, s) = .Cells(z, s)
End If
Next z
Next s
For z = 1 To 9 'quadratische Prüfung
For s = 1 To 9
zq = Int((z - 1) / 3) \* 3 + 1
sq = Int((s - 1) / 3) \* 3 + 1
If Len(m(z, s)) \> 1 Then
For n = 1 To 9
If Application.WorksheetFunction.CountIf(.Range(.Cells(zq, sq), .Cells(zq, sq).Offset(2, 2)), CStr(n)) \> 0 Then
m(z, s) = Replace(m(z, s), CStr(n), "")
If Len(m(z, s)) = 1 Then
.Cells(z, s) = m(z, s)
GoTo nochmal
End If
End If
Next n
End If
Next s
Next z
For z = 1 To 9
For s = 1 To 9
.Cells(z, s) = m(z, s)
Next s
Next z
For z = 1 To 9 Step 3 'quadratische Prüfung auf einmalige Ziffer
For s = 1 To 9 Step 3
Wert = ""
For Each Zelle In .Range(.Cells(z, s), .Cells(z, s).Offset(2, 2))
Wert = Wert & CStr(Zelle.Value)
Next Zelle
For Each Zelle In .Range(.Cells(z, s), .Cells(z, s).Offset(2, 2))
If Len(Zelle) \> 1 Then
For n = 1 To Len(Zelle)
If InStr(InStr(Wert, Mid(Zelle, n, 1)) + 1, Wert, Mid(Zelle, n, 1)) = 0 Then
Zelle.Value = Mid(Zelle, n, 1)
m(Zelle.Row, Zelle.Column) = Zelle.Value
neu = True
GoTo weiter
End If
Next n
End If
Next Zelle
weiter:
Next s
Next z
If neu = True Then
neu = False
For Each Zelle In .Range("A1:I9")
If Len(Zelle) \> 1 Then Zelle.Value = ""
Next Zelle
GoTo nochmal
End If
ws1.Range("A1:I9").Copy Destination:=.Range("A11")
.Activate
End With
End Sub
Function doppelt(ByVal Wert)
Dim n
With Worksheets("Tabelle2")
doppelt = False
For n = 1 To Len(Wert)
If InStr(InStr(Wert, n) + 1, Wert, n) 0 Then
doppelt = True
Exit For
End If
Next n
End With
End Function
