Sudoku Spiel mit VBA Excel programmieren

Sudoku Spiel mit VBA Excel programmieren

Author D.Selzer/McKenzie

Video: https://youtu.be/9jIXI4PDkYs

Hier zeige ich Ihnen, wie Sie mit einfachem Code ein umfangreiches Sudoku-Spiel mit Excel-VBA  programmieren können.

Den Source-Code VBA können Sie im Forum

http://Outbackbrumby.Blogspot.com

herunterladen.

 

Hier der SourceCode VBA>

Public Sub CreateMySudoku()

   Dim colResult     As Collection

   Dim varSolutions  As Variant

   Dim dtmBegin      As Date

   Dim i             As Long

   Dim k             As Long

   Dim m             As Long

  

   ' Zeitpunkt Beginn speichern

   dtmBegin = Now()

  

   ' Collection mit Lösungen erzeugen

   Set colResult = CreateSudoku

  

   ' Zieltabelle

   With Worksheets("Create Sudoku")

      .Range("A1:I9").ClearContents

     

      ' Alle Lösungen durchlaufen, momentan

      ' nur eine pro Durchlauf möglich

      For Each varSolutions In colResult

        

         For i = 1 To 9

            m = m + 1

            For k = 1 To 9

               ' Wert in Tabelle schreiben

               .Cells(m, k) = varSolutions(i, k)

            Next k

         Next i

        

      Next varSolutions

     

      ' Zeitdauer ausgeben

      MsgBox "Dauer : " & Format(Now() - dtmBegin, "nn:ss"), , _

         "Sudoku erzeugen"

        

   End With

  

End Sub

Private Function CreateSudoku( _

   Optional avarAll As Variant, _

   Optional colResult As Collection, _

   Optional varResult As Variant, _

   Optional Level As Long = 1, _

   Optional varOrder As Variant, _

   Optional blnEnd As Boolean, _

   Optional curCount As Currency _

   ) As Collection

  

   Dim i                         As Long

   Dim k                         As Long

   Dim m                         As Long

   Dim o                         As Long

   Dim x                         As Long

   Dim y                         As Long

   Dim blnImpossible             As Boolean

   Dim varDummy                  As Variant

   Dim astrSource(1 To 9)        As String

   Dim astrColumn(1 To 9)        As String

   Dim astrSquare(1 To 3)        As String

   Dim lngCount(1 To 9)          As Long

  

   ' Zufallsgenerator initialisieren

   Randomize

  

   If Level = 1 Then

  

      Set colResult = New Collection

     

      ReDim varResult(1 To 9, 1 To 9)

  

      ' Reihenfolge der Anfangsziffern

      varOrder = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)

     

      ' Elemente 1-9 mischen

      For i = 1 To 9

         k = Int(Rnd * 9 + 1)

         varOrder(0) = varOrder(i)

         varOrder(i) = varOrder(k)

         varOrder(k) = varOrder(0)

      Next

     

      ' Aus Collection ein mehrdimensionales Array machen,

      ' um Verarbeitung zu beschleunigen.

      ' 1. Dimension Anfangsziffern 1-9

      ' 2. Dimension 10 Elemente der Kombination.

      ' 3. Dimension 40320 Kombinationen pro Anfangsziffer

      ' 3. Dimension Element Nr. 0 = Puffer

      ReDim avarAll(1 To 9, 0 To 9, 0 To 40320)

     

      Application.StatusBar = "Kombinationen erzeugen"

     

      ' Alle Kombinationen durchlaufen

      For Each varDummy In MakeSudokuKombinations()

     

         ' Aktuelle Anfangsziffer. (1. Dimension)

         k = varDummy(1)

        

         ' Aktuelle Position im Array (3. Dimension)

         lngCount(k) = lngCount(k) + 1

        

         ' Kombinationen im mehrdimensionalem Array speichern

         For i = 0 To 9 ' 2. Dimension

            avarAll(k, i, lngCount(k)) = varDummy(i)

         Next

     

      Next varDummy

     

      ' Mischen

      Application.StatusBar = "Kombinationen mischen"

      For x = 1 To 9

         For y = 1 To 40320

            ' Zufallszahl erzeugen

            k = Int(Rnd * 40320 + 1)

            For i = 0 To 9

               ' Gewähltes Element mit dem in der aktuellen

               ' Reihenfolge stehenden tauschen. Das in der

               ' aktuellen Reihenfolge stehende wird im

               ' nächsten Durchlauf nicht mehr berücksichtigt

               ' Dazu je drei mal Ziffern tauschen. Element Nr.: 0

               ' dient als Puffer zur Zwischenspeicherung

               avarAll(x, i, 0) = avarAll(x, i, k)

               avarAll(x, i, k) = avarAll(x, i, y)

               avarAll(x, i, y) = avarAll(x, i, 0)

            Next i

         Next y

      Next x

     

      Set varDummy = Nothing

     

   Else

  

      ' Aus dem bisherigen Zahlen ein eindimensionales

      ' Stringarray machen. Jede Spalte ein Element,

      ' zusammengesetzt aus allen Ziffern einer Spalte

      For i = 1 To Level - 1

         For k = 1 To 9

            astrColumn(k) = astrColumn(k) & varResult(i, k)

         Next k

      Next i

        

      ' Aus dem bisherigen Zahlen ein eindimensionales

      ' Stringarray machen. Jeder Neunerblock der aktuellen

      ' Zeile ein Element, zusammengesetzt aus allen Ziffern

      ' des jeweiligen Neunerblocks

      Erase astrSquare

      i = Level - 1

      k = Level - 2

      Select Case Level

         Case 2, 5, 8

            astrSquare(1) = _

               varResult(i, 1) & varResult(i, 2) & varResult(i, 3)

            astrSquare(2) = _

               varResult(i, 4) & varResult(i, 5) & varResult(i, 6)

            astrSquare(3) = _

               varResult(i, 7) & varResult(i, 8) & varResult(i, 9)

         Case 3, 6

            astrSquare(1) = _

               varResult(k, 1) & varResult(k, 2) & varResult(k, 3) & _

               varResult(i, 1) & varResult(i, 2) & varResult(i, 3)

            astrSquare(2) = _

               varResult(k, 4) & varResult(k, 5) & varResult(k, 6) & _

               varResult(i, 4) & varResult(i, 5) & varResult(i, 6)

            astrSquare(3) = _

               varResult(k, 7) & varResult(k, 8) & varResult(k, 9) & _

               varResult(i, 7) & varResult(i, 8) & varResult(i, 9)

      End Select

     

   End If

  

   ReDim varDummy(0 To 9)

  

   ' Aktuelle Anfangszahl dieser Ebene auslesen

   x = varOrder(Level)

  

   For y = 1 To 40320

      ' In einer Schleife alle Zahlen durchlaufen

  

      For i = 0 To 9

     

         ' Gewähltes Element in Array "varDummy" kopieren

         varDummy(i) = avarAll(x, i, y)

        

      Next i

     

     

      blnImpossible = False

     

      For i = 1 To 9

     

         m = (i - 1) \ 3 + 1 ' Aktuellen Block berechnen

        

         ' Überprüfen, ob die Ziffer in der Spalte,

         ' oder im aktuellen Neunerblock bereits

         ' vorkommt

         If InStr(astrSquare(m), varDummy(i)) > 0 Then _

            blnImpossible = True: Exit For

         If InStr(astrColumn(i), varDummy(i)) > 0 Then _

            blnImpossible = True: Exit For

           

      Next i

     

      ' Getestete Kombinationen zählen

      curCount = curCount + 1

     

      ' Notausstieg

      If curCount > 5000000 Then

         blnEnd = True

         MsgBox "5.000.000 Kombinationen getestet!" & vbCrLf & _

            "Probieren Sie es noch einmal.", , "Abbruch"

      End If

     

      If (curCount Mod 1000) = 0 Then

         ' Alle 1000 Kombinationen Statusbar ansprechen

         Application.StatusBar = "Getestete Kombinationen : " _

            & Format(curCount, "#,##0")

         ' Alle 10000 Kombinationen ein Abarbeiten

         ' der Ereignisse zulassen

         If (curCount Mod 10000) = 0 Then DoEvents

      End If

     

      If blnImpossible = False Then

     

         ' Ziffer kommt weder in Spalte, noch im

         ' aktuellen Quadrat vor

     

         For i = 1 To 9

            ' Aktuelle Kombination dieser Ebene

            ' ins Ergebnisarray

            varResult(Level, i) = varDummy(i)

         Next i

        

         If Level = 9 Then

        

            ' Ergebnis zur Collection hinzufügen

            colResult.Add varResult

           

            ' Zum Beenden Variable auf True setzen

            blnEnd = True

           

         Else

        

            ' Funktion rekursiv aufrufen

            CreateSudoku avarAll, colResult, _

               varResult, Level + 1, varOrder, blnEnd, curCount

              

         End If

        

      End If

     

      ' Ergebnis gefunden, Schleife verlassen

      If blnEnd Then Exit For

     

   Next y

  

  

   If Level = 1 Then

  

      ' Collection als Funktionsergebnis zurückgeben

      Set CreateSudoku = colResult

     

      ' Statusbar zurücksetzen

      Application.StatusBar = False

     

   End If

  

End Function

 

Private Function MakeSudokuKombinations( _

   Optional ByVal varBefore As Variant, _

   Optional Level As Long = 1, _

   Optional colAll As Collection _

   ) As Collection

  

   Dim i             As Long

   Dim strKey        As String

  

   If colAll Is Nothing Then Set colAll = New Collection

  

   Select Case Level

  

      Case 1

     

         ' Array mit 10 Elementen erzeugen, Element Nr.: 0

         ' nimmt später Kombination als Zeichenkette auf

         varBefore = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)

        

      Case 9

     

         ' Kombination als Zeichenkette

         strKey = Mid(Join(varBefore, ""), 2)

        

         ' Element 0 nimmt die Zeichenkette auf

         varBefore(0) = strKey

        

         ' Kombination zur Kollection hinzufügen

         colAll.Add varBefore

        

         Exit Function

        

   End Select

  

   For i = Level To 9

  

      ' Jede Ziffer ab der aktuellen Level an die

      ' Position der aktuellen Level bringen, dazu

      ' je drei mal Ziffern tauschen. Element Nr.: 0

      ' dient als Puffer zur Zwischenspeicherung

      varBefore(0) = varBefore(Level)

      varBefore(Level) = varBefore(i)

      varBefore(i) = varBefore(0)

     

      ' Rekursiv aufrufen

      MakeSudokuKombinations varBefore, Level + 1, colAll

     

   Next

  

   ' Collection als Funktionsergebnis zurückgeben

   If Level = 1 Then Set MakeSudokuKombinations = colAll

  

End Function

 

Public Sub SolveMySudoku()

   Dim colResult     As Collection

   Dim varSource     As Variant

   Dim varSolutions  As Variant

   Dim varNumbers    As Variant

   Dim dtmBegin      As Date

   Dim i             As Long

   Dim k             As Long

   Dim m             As Long

  

   ' Zeitpunkt Beginn speichern

   dtmBegin = Now()

  

   ' Bereich in ein Variantarray beamen

   varSource = Worksheets("Sudoku").Range("A1:I9")

  

   ' Collection mit Lösungen erzeugen

   Set colResult = SolveSudoku(varSource)

  

   ' Zieltabelle

   With Worksheets("Sudoku")

      .Range("A21:I29").ClearContents

      .Range("A31:I1000").ClearContents

      .Range("F12").Value = 0

 

      ' 1. Zeile (-1) der Lösungsausgabe

      m = 20

     

      If Not (colResult Is Nothing) Then

     

         ' Alle Lösungen durchlaufen

         For Each varSolutions In colResult

           

            For i = 1 To 9

               m = m + 1

               For k = 1 To 9

                  ' Wert in Tabelle schreiben

                  .Cells(m, k) = varSolutions(i, k)

               Next k

            Next i

           

            ' Zwischen den Lösungen 5 Zeilen freilassen

            m = m + 5

           

         Next varSolutions

        

         ' Anzahl Lösungen ausgeben

         .Range("F12").Value = colResult.Count

        

      End If

     

     

      ' Zeitdauer ausgeben

      .Range("J12").Value = Now() - dtmBegin

        

   End With

  

End Sub

 

Private Function SolveSudoku( _

   varSource As Variant, _

   Optional varAll As Variant, _

   Optional colResult As Collection, _

   Optional varResult As Variant, _

   Optional Level As Long = 1, _

   Optional curCount As Currency _

   ) As Collection

   Dim i                            As Long

   Dim k                            As Long

   Dim m                            As Long

   Dim o                            As Long

   Dim blnImpossible                As Boolean

   Dim varDummy                     As Variant

   Dim colDummy(1 To 9)             As New Collection

   Dim astrSource(1 To 9)           As String

   Dim astrColumn(1 To 9)           As String

   Dim astrSquare(1 To 3)           As String

   Dim astrFilter(1 To 9, 1 To 9)   As String

  

   On Error GoTo ErrorHandler

  

   If Level = 1 Then

   ' Erster Funktionsaufruf

  

      For i = 1 To 9 ' Jede Zeile

         For k = 1 To 9

        

            ' Aus dem Quellbereich ein eindimensionales Stringarray

            ' machen. Jedes Element enthält alle Ziffern einer

            ' Zeile als zusammengesetze Zeichenkette, wobei leere

            ' Felder durch Fragezeichen ersetzt werden.

            ' Fragezeichen "?" ersetzen ein beliebiges Zeichen

            ' beim Operator "Like"

             If Len(varSource(i, k)) = 0 Then varSource(i, k) = "?"

            astrSource(i) = astrSource(i) & varSource(i, k)

           

            ' Aus den Ziffern der jeweiligen Spalte ausschließlich

            ' der aktuellen Zeile ein Stringarray machen

            For m = 1 To 9 ' Jede Spalte

               If k <> i Then

                  ' Jede Zeile außer aktueller

                  astrFilter(i, m) = astrFilter(i, m) & varSource(k, m)

               End If

            Next m

           

         Next k

      Next i

           

      varSource = astrSource

     

      Application.StatusBar = "Kombinationen erzeugen"

 

      ' Alle Kombinationen durchlaufen

      For Each varDummy In MakeSudokuKombinations()

     

         ' Jede Zeile des Quellbereichs durchlaufen

         For i = 1 To 9

           

            ' Das Element mit dem Index 0

            ' enthält alle Ziffern der Kombination

            ' als zusammengesetze Zeichenkette.

            ' Mit dem Muster der aktuellen Zeile

            ' des Quellbereichs vergleichen

            If varDummy(0) Like astrSource(i) Then

              

               ' Überprüfen, ob Ziffer der jeweiligen Spalte

               ' und der aktuellen Zeile einmalig ist

               blnImpossible = False

               For k = 1 To 9

                  If InStr(astrFilter(i, k), varDummy(k)) <> 0 Then

                     blnImpossible = True

                     Exit For

                  End If

               Next k

           

               ' Muster stimmen überein! Ziffer in Spalte einmalig!

               ' Zur neuen Collection hinzufügen, die anschließend

               ' nur die notwendigen Kombinationen enthält

               If blnImpossible = False Then colDummy(i).Add varDummy

           

            End If

           

         Next i

        

      Next varDummy

     

      ' Funktionsinterne Variable auf erzeugte Collection

      varAll = colDummy

     

      ' Neue Collection anlegen

      Set colResult = New Collection

     

      ' Zielarray anlegen

      ReDim varResult(1 To 9, 1 To 9)

     

   End If

  

   ' Aus dem bisherigen Zahlen ein eindimensionales Stringarray

   ' machen. Jede Spalte ein Element, zusammengesetzt aus allen

   ' Ziffern einer Spalte

   For i = 1 To Level - 1

      For k = 1 To 9

         astrColumn(k) = astrColumn(k) & varResult(i, k)

      Next k

   Next i

  

   ' Aus dem bisherigen Zahlen ein eindimensionales Stringarray

   ' machen. Jeder Neunerblock der aktuellen  Zeile ein Element,

   ' zusammengesetzt aus allen Ziffern des jeweiligen Neunerblocks

   Erase astrSquare

   i = Level - 1

   k = Level - 2

   Select Case Level

      Case 2, 5, 8

         astrSquare(1) = _

            varResult(i, 1) & varResult(i, 2) & varResult(i, 3)

         astrSquare(2) = _

            varResult(i, 4) & varResult(i, 5) & varResult(i, 6)

         astrSquare(3) = _

            varResult(i, 7) & varResult(i, 8) & varResult(i, 9)

      Case 3, 6

         astrSquare(1) = _

            varResult(k, 1) & varResult(k, 2) & varResult(k, 3) & _

            varResult(i, 1) & varResult(i, 2) & varResult(i, 3)

         astrSquare(2) = _

            varResult(k, 4) & varResult(k, 5) & varResult(k, 6) & _

            varResult(i, 4) & varResult(i, 5) & varResult(i, 6)

         astrSquare(3) = _

            varResult(k, 7) & varResult(k, 8) & varResult(k, 9) & _

            varResult(i, 7) & varResult(i, 8) & varResult(i, 9)

   End Select

 

  

   For Each varDummy In varAll(Level)

  

      blnImpossible = False

      For i = 1 To 9

         ' Überprüfen, ob die Ziffer in der Spalte,

         ' oder im aktuellen Neunerblock bereits vorkommt

         m = (i - 1) \ 3 + 1

         If InStr(astrSquare(m), varDummy(i)) > 0 Then _

            blnImpossible = True: Exit For

         If InStr(astrColumn(i), varDummy(i)) > 0 Then _

            blnImpossible = True: Exit For

      Next i

     

      ' Getestete Kombinationen zählen

      curCount = curCount + 1

     

      If (curCount Mod 1000) = 0 Then

     

         ' Alle 1000 Kombinationen die Statusbar ansprechen

         Application.StatusBar = "Getestete Kombinationen : " _

            & Format(curCount, "#,##0")

           

         ' Alle 5000 Kombinationen ein Abarbeiten

         ' der Ereignisse zulassen

         If (curCount Mod 5000) = 0 Then DoEvents

        

      End If

     

      If blnImpossible = False Then

      ' Ziffer kommt weder in Spalte, noch im aktuellen Quadrat vor

        

         For i = 1 To 9

            ' Aktuelle Kombination dieser Ebene

            ' ins Ergebnisarray

            varResult(Level, i) = varDummy(i)

         Next

        

         If Level = 9 Then

            ' Ergebnis zur Collection hinzufügen

            colResult.Add varResult

         Else

            ' Funktion rekursiv aufrufen

            SolveSudoku varSource, varAll, colResult, varResult, _

               Level + 1, curCount

         End If

        

      End If

     

   Next varDummy

  

  

   If Level = 1 Then

  

      ' Collection als Funktionsergebnis zurückgeben

      Set SolveSudoku = colResult

     

      ' Statusbar zurücksetzen

      Application.StatusBar = False

     

   End If

  

   Exit Function

ErrorHandler:

   ' Statusbar zurücksetzen

   Application.StatusBar = False

End Function

 

Private Function MakeSudokuKombinations( _

   Optional ByVal varBefore As Variant, _

   Optional Level As Long = 1, _

   Optional colAll As Collection _

   ) As Collection

  

   Dim i             As Long

   Dim strKey        As String

  

   If colAll Is Nothing Then Set colAll = New Collection

  

   Select Case Level

  

      Case 1

     

         ' Array mit 10 Elementen erzeugen, Element Nr.: 0

         ' nimmt später Kombination als Zeichenkette auf

         varBefore = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9)

        

      Case 9

     

         ' Kombination als Zeichenkette

         strKey = Mid(Join(varBefore, ""), 2)

        

         ' Element 0 nimmt die Zeichenkette auf

         varBefore(0) = strKey

        

         ' Kombination zur Kollection hinzufügen

         colAll.Add varBefore

        

         Exit Function

        

   End Select

  

   For i = Level To 9

  

      ' Jede Ziffer ab der aktuellen Level an die

      ' Position der aktuellen Level bringen, dazu

      ' je drei mal Ziffern tauschen. Element Nr.: 0

      ' dient als Puffer zur Zwischenspeicherung

      varBefore(0) = varBefore(Level)

      varBefore(Level) = varBefore(i)

      varBefore(i) = varBefore(0)

     

      ' Rekursiv aufrufen

      MakeSudokuKombinations varBefore, Level + 1, colAll

     

   Next

  

   ' Collection als Funktionsergebnis zurückgeben

   If Level = 1 Then Set MakeSudokuKombinations = colAll

  

End Function