AW: Wegeproblem mit VBA lösen
09.12.2014 15:59:43
ChrisL
Hi Uppe
Ich konnte es nicht lassen und habe mal etwas rumgespielt. Siehe Beispieldatei:
https://www.herber.de/bbs/user/94314.xlsm
Das Prinzip ist, dass nach dem Zufallsprinzip Wege eingeschlagen werden, bis es keine weiteren Optionen mehr gibt. Im Bereich AG1:AU10 ist der Lösungsweg mit den wenigsten leeren Feldern angezeigt. Sobald dort alles voll ist, hast du die Lösung.
Die richtige Lösung zu finden ist wie ein 6er im Lotto, da keine Logik eingebaut ist (reiner Zufall). Eine Kaffee-Pause hat nicht gereicht, aber wer weiss, vielleicht hast du ja Glück wenn du das Programm mal ein paar Stunden laufen lässt ;)
Der Weg bis Feld 5 habe ich in der Ausgangslage vordefiniert, da dies aufgrund der Aufgabenstellung m.E. gegeben ist.
n.b. Das Programm berücksichtigt keine diagonalen und keine doppelten Wege. Falls dies auch erlaubt wäre, bitte um Mitteilung.
Viel Spass, cu
Chris
Sub MachmalEinPaarDurchlaeufe()
Do
Call ZufallsgeneratorStarten
Loop
End Sub
Private Sub ZufallsgeneratorStarten()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim arAktuellePosition(2) As Variant ' 0=Zeile, 1=Spalte, 2=Nummer
Set WS1 = Worksheets("Spiel")
Set WS2 = Worksheets("Hilfstabelle")
With WS1
' Ausgangslage wieder herstellen
.Range("AY4:AY10").ClearContents
.Range("A1:O10").Value = .Range("Q1:AE10").Value
.Range("A1") = 1
arAktuellePosition(0) = 4
arAktuellePosition(1) = 2
arAktuellePosition(2) = 5
Do
' Möglicher Weg in alle 4 Richtungen ermitteln und auf Hilfstabelle eintragen
WS2.Range("A2:C5").ClearContents
Call VierRichtungen(CInt(arAktuellePosition(0)) - 1, CInt(arAktuellePosition(1)))
Call VierRichtungen(CInt(arAktuellePosition(0)), CInt(arAktuellePosition(1)) - 1)
Call VierRichtungen(CInt(arAktuellePosition(0)) + 1, CInt(arAktuellePosition(1)))
Call VierRichtungen(CInt(arAktuellePosition(0)), CInt(arAktuellePosition(1)) + 1)
If WS2.Range("A2") = "" Then
' wenn es keinen neuen Weg gibt
If WorksheetFunction.CountBlank(.Range("A1:O10"))
Private Sub VierRichtungen(neuZeile As Integer, neuSpalte As Integer)
Dim intZeile As Integer
If neuZeile > 0 And neuSpalte > 0 Then
If neuZeile
Private Function checkFix(strKoordinaten As String) As Boolean
With Worksheets("Spiel")
If WorksheetFunction.CountIf(.Range("AX2:AX8"), strKoordinaten) > 0 Then
If strKoordinaten .Range("AY10").End(xlUp).Offset(1, -1) Then Exit Function
End If
End With
checkFix = True
End Function