Hallo Wissende,
in viele Tageszeitungen findet man jetzt Sudoko, soll süchtig machen, mal ausprobieren.
Es ist ein Quadrat von 9*9 Zellen, unterteilt in 9 Quadrate von 3*3 Zellen.
In jedem kleinen Quadrat sind einige Zellen (3-5 vorbelegt). Nun sollen die leeren Zellen mit den Ziffern 1 bis 9 befüllt werden dass folgende Regeln gelten:
In jedem der 9 kleinen Quadrate darf jede Zahl nur einmal vorkommen
Desgleichen in jeder Zeile und Spalte des großen Quadrates.
Das Sodoku der Frankfurter Rundschau vom 8.8 sieht so aus: Abcdefghi 3 8 7 3 7 9 8 2 6 1 8 38 56 4 5 8 1 9 4 2 6 4 9 6 Mein nachfolgender Code läuft bis es so aussieht: Abcdefghi 536184 7 dann hängt er sich auf, ist klar, er müßte die 2 oder 9 finden aber beide stehen schon in Spalte G. Jetzt fehlt mir die Idee/Code wie ich das mache dass er sich z.b. die 5 in A1 merkt mit einem anderen Wert in A nochmals probiert und falls das auch schiefgeht sich auch diesen merkt usw bis es klappt. An sich fehlt mir noch gesamte schwierige Teil des Codes *g Die Datei: <a href="https://www.herber.de/bbs/user/25510.xls">https://www.herber.de/bbs/user/25510.xls</a> Jetzt beim Schreiben kommt mit eine Idee, ich werde eine Variable anlegen, Dim V(9,9,9) und in der letzten Dimension die "verbotenen" Zahlen ablegen, also die die schon in der Reihe stehen und die mit denen es schon mal schiefging wie hier mit der 5 in A1. Vielleicht hat auch einer einen schnelleren oder besseren Grundansatz für das Problem. Gruß Reinhard Sub Sudoko() Dim z As Byte, s As Byte, x as Byte For z = 1 To 9 For s = 1 To 9 While Cells(z, s) = "" x = Int(Rnd() * 9) + 1 zähl = zähl + 1 If Application.WorksheetFunction.CountIf(Range(Cells(z, 1), Cells(z, 9)), x) = 0 _ And Application.WorksheetFunction.CountIf(Range(Cells(1, s), Cells(9, s)), x) = 0 Then Cells(z, s) = x 'call pruef(z,s,x) End If Wend Next s Next z End Sub Sub zurücksetzen() Range("K12:s21").Copy Destination:=[a1] End Sub Sub pruef(z, s, x) 'Pruef zu prüfen, soweit kam ich noch nicht :-) z1 = z s1 = s While Int(z1 / 4) <> z1 / 4 z1 = z1 - 1 Wend While Int(s1 / 4) <> s1 / 4 s1 = s1 - 1 Wend If Application.WorksheetFunction.CountIf(Range(Cells(z1, s1), Cells(z1 + 2, s1 + 2)), x) = 0 Then Cells(z, s) = x End If End Sub