Symbolrechnen

Sub test() Dim Zahlen Dim Anz As Long Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long, o As Long, p As Long, q _ _ _ As Long, r As Long Dim A As Long, B As Long, C As Long, D As Long, E As Long, F As Long, G As Long, H As Long Dim Zeile As Long Dim Zeile_1 As Long Dim Erg, f1, f2, f3, f4, f5 Anz = Range("Anz") ReDim Erg(1 To WorksheetFunction.Combin(Anz, 8), 1 To 30) Zahlen = Range("Zahlenliste").Resize(Anz, 1) Zeile = 0 Zeile_1 = 0 Range("C:Z").ClearContents For A = 1 To Anz Application.StatusBar = "Bearbeitet: " & Format(A / Anz, "0%") For B = 1 To Anz For C = 1 To Anz For D = 1 To Anz For E = 1 To Anz For F = 1 To Anz For G = 1 To Anz For H = 1 To Anz If Not (B = A Or C = A Or D = A Or E = A Or F = A Or G = A _ _ _ Or H = A Or C = B Or D = B Or E = B Or F = B Or G = B Or H = B Or D = C Or E = C Or F = C Or G = _ _ C Or H = C Or E = D Or F = D Or G = D Or H = D Or F = E Or G = E Or H = E Or G = F Or H = F Or _ H = G) Then f1 = Zahlen(A, 1) & Zahlen(B, 1) & Zahlen(C, 1) & _ Zahlen(B, 1) f2 = Zahlen(B, 1) & Zahlen(D, 1) & Zahlen(E, 1) & _ Zahlen(F, 1) f3 = Zahlen(G, 1) & Zahlen(H, 1) & Zahlen(A, 1) & _ Zahlen(H, 1) f4 = Zahlen(D, 1) & Zahlen(A, 1) & Zahlen(B, 1) & _ Zahlen(A, 1) f5 = (f1 - f2 + f3) Zeile = 1 Erg(Zeile, 12) = f1 Erg(Zeile, 13) = "-" Erg(Zeile, 14) = f2 Erg(Zeile, 15) = "+" Erg(Zeile, 16) = f3 Erg(Zeile, 17) = "=" Erg(Zeile, 18) = Int(Zahlen(D, 1) & Zahlen(A, 1) & _ _ _ Zahlen(B, 1) & Zahlen(A, 1)) Erg(Zeile, 19) = f5 Erg(Zeile, 20) = Int(Zahlen(A, 1) & Zahlen(B, 1) & _ _ _ Zahlen(C, 1) & Zahlen(D, 1) & Zahlen(E, 1) & Zahlen(F, 1) & Zahlen(G, 1) & Zahlen(H, 1)) End If Next Next Next Next Next Next Next Next Cells(1, 3).Resize(UBound(Erg, 1), UBound(Erg, 2)) = Erg Application.StatusBar = False End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Main() Dim N As Integer, K As Integer, t As Single N = 10 K = 8 t = Timer VariationenOhneZurueckLegen N, K Debug.Print "Array", Timer - t End Sub Sub VariationenOhneZurueckLegen(ByVal N As Integer, ByVal K As Integer) Dim ar() As Long, lngSize As Long, i As Long, j As Integer lngSize = WorksheetFunction.Fact(N) / WorksheetFunction.Fact(N - K) ReDim ar(1 To K) For j = 1 To K ar(j) = j Next CheckVal 1, K, ar ' Debug.Print i; ":";: For j = 1 To k: Debug.Print ar(j);: Next: Debug.Print For i = 2 To lngSize arIncNoDup ar, N, K, K CheckVal i, K, ar ' Debug.Print i; ":";: For j = 1 To k: Debug.Print ar(j);: Next: Debug.Print Next End Sub Private Sub arIncNoDup(ByRef ar() As Long, ByVal N As Integer, ByVal K As Integer, ByVal _ intSpalte As Integer) Dim j As Integer, l As Integer, m As Integer ReDim arInUse(0 To N) For j = 1 To K If j intSpalte Then arInUse(ar(j)) = 1 Next For j = ar(intSpalte) + 1 To N If arInUse(j) 1 Then ar(intSpalte) = j arInUse(j) = 1 For l = intSpalte + 1 To K For m = 1 To K If arInUse(m) = 0 Then ar(l) = m arInUse(m) = 1 Exit For End If Next m Next l Exit Sub End If Next For j = intSpalte To K ar(j) = 0 Next arIncNoDup ar, N, K, intSpalte - 1 End Sub Private Sub CheckVal(ByVal i As Long, ByVal K As Integer, ByRef a() As Long) Static lngZeile As Long Dim v(1 To 4) As Long, v2 As Long, v3 As Long, v4 As Long ' ABCB - BDEF + GHAH = DABA ' A=1,B=2,C=3,D=4,E=5,F=6,G=7,H=8 ' In a(i) steht 1...10, das auf 0...9 umbiegen v(1) = 1000 * (a(1) - 1) + 100 * (a(2) - 1) + 10 * (a(3) - 1) + (a(2) - 1) v(2) = 1000 * (a(2) - 1) + 100 * (a(4) - 1) + 10 * (a(5) - 1) + (a(6) - 1) v(3) = 1000 * (a(7) - 1) + 100 * (a(8) - 1) + 10 * (a(1) - 1) + (a(8) - 1) v(4) = 1000 * (a(4) - 1) + 100 * (a(1) - 1) + 10 * (a(2) - 1) + (a(1) - 1) If v(1) - v(2) + v(3) = v(4) Then lngZeile = lngZeile + 1 Cells(lngZeile, 1).Value = v(1) Cells(lngZeile, 2).Value = v(2) Cells(lngZeile, 3).Value = v(3) Cells(lngZeile, 4).Value = v(4) End If End Sub

Option Explicit Sub Main() Dim N As Integer, K As Integer, t As Single Static lngZeile As Long lngZeile = 0 N = 10 K = 8 t = Timer VariationenOhneZurueckLegen N, K Debug.Print "Array", Timer - t End Sub Sub VariationenOhneZurueckLegen(ByVal N As Integer, ByVal K As Integer) Dim ar() As Long, lngSize As Long, i As Long, j As Integer lngSize = WorksheetFunction.Fact(N) / WorksheetFunction.Fact(N - K) ReDim ar(1 To K) For j = 1 To K ar(j) = j Next CheckVal 1, K, ar ' Debug.Print i; ":";: For j = 1 To k: Debug.Print ar(j);: Next: Debug.Print For i = 2 To lngSize arIncNoDup ar, N, K, K CheckVal i, K, ar ' Debug.Print i; ":";: For j = 1 To k: Debug.Print ar(j);: Next: Debug.Print Next End Sub Private Sub arIncNoDup(ByRef ar() As Long, ByVal N As Integer, ByVal K As Integer, ByVal _ intSpalte As Integer) Dim j As Integer, l As Integer, m As Integer ReDim arInUse(0 To N) For j = 1 To K If j intSpalte Then arInUse(ar(j)) = 1 Next For j = ar(intSpalte) + 1 To N If arInUse(j) 1 Then ar(intSpalte) = j arInUse(j) = 1 For l = intSpalte + 1 To K For m = 1 To K If arInUse(m) = 0 Then ar(l) = m arInUse(m) = 1 Exit For End If Next m Next l Exit Sub End If Next For j = intSpalte To K ar(j) = 0 Next arIncNoDup ar, N, K, intSpalte - 1 End Sub Private Sub CheckVal(ByVal i As Long, ByVal K As Integer, ByRef x() As Long) Static lngZeile As Long Dim v(1 To 20) As Long, v2 As Long, v3 As Long, v4 As Long, v5 As Long, v6 As Long, v7 As _ Long, v8 As Long Dim v9 As Long, v10 As Long, v11 As Long, v12 As Long, v13 As Long, v14 As Long, v15 As Long, _ v16 As Long Dim v17 As Long, v18 As Long, v19 As Long, v20 As Long Dim A As Long, B As Long, C As Long, D As Long, E As Long, F As Long, G As Long, H As Long ' Die Aufgabe die es zu lösen gilt ' ABCB - BDEF + GHAH = DABA ' GDCH / F * H = FABE ' HCHG + AC - DAFC = GEGG ' HDGE - FCDA + HFHB = BAGC ' ABCB - BDEF + GHAH = DABA ' A=1,B=2,C=3,D=4,E=5,F=6,G=7,H=8 ' In x(i) steht 1...10, das auf 0...9 umbiegen A = x(1) - 1 B = x(2) - 1 C = x(3) - 1 D = x(4) - 1 E = x(5) - 1 F = x(6) - 1 G = x(7) - 1 H = x(8) - 1 'erste Zeile berechnen, da hier alle Variablen vorkommen v(1) = 1000 * A + 100 * B + 10 * C + B v(2) = 1000 * B + 100 * D + 10 * E + F v(3) = 1000 * G + 100 * H + 10 * A + H v(4) = 1000 * D + 100 * A + 10 * B + A 'Ergebnis Zeile 1 If v(1) - v(2) + v(3) = v(4) Then 'Zahlen von Ergebnis mit Rechenoperation _ vergleichen 'Wenn der Vergleich positiv ist alle weiteren Zeilen und Spalten durchrechnen If Not (F = 0 Or H = 0) Then 'Ausschließen, dass Buchstabe F und H = 0 _ ist v(5) = 1000 * G + 100 * D + 10 * C + H v(6) = F v(7) = H v(8) = v(5) / v(6) * v(7) 'Ergebnis Zeile 2 v(9) = 1000 * H + 100 * C + 10 * H + G v(10) = 10 * A + C v(11) = 1000 * D + 100 * A + 10 * F + C v(12) = v(9) + v(10) - v(11) 'Ergebnis Zeile 3 v(16) = v(4) + v(8) - v(12) 'Endsumme Zeile 1 - 3 Ergebnisse - BAGC v(17) = v(1) + v(5) - v(9) 'Ergebnis Spalte 1 v(18) = v(2) / v(6) + v(10) 'Ergebnis Spalte 2 v(19) = v(3) / v(7) + v(11) 'Ergebnis Spalte 3 v(20) = v(17) - v(18) + v(19) 'Endsumme Spalte 1 - 3 Ergebnisse - BAGC If ((v(16) 999) And (v(20) 999)) Then 'nur _ veistellige Ergebnisse zulassen lngZeile = lngZeile + 1 Cells(lngZeile, 1).Value = A & B & C & D & E & F & G & H Cells(lngZeile, 2).Value = v(16) Cells(lngZeile, 3).Value = v(20) End If End If End If 'lngZeile = 0 End Sub

Ich habe nun alle Formeln durch gerechnet. Nur das Ergebnis ist noch unstimmig. Aber die Aufgabe muss doch lösbar sein. Hier mein Vorgehen:


Option Explicit
Sub Main()
Dim N As Integer, K As Integer, t As Single
Static lngZeile As Long
lngZeile = 0
N = 10
K = 8
t = Timer
VariationenOhneZurueckLegen N, K
Debug.Print "Array", Timer - t
End Sub
Sub VariationenOhneZurueckLegen(ByVal N As Integer, ByVal K As Integer)
Dim ar() As Long, lngSize As Long, i As Long, j As Integer
lngSize = WorksheetFunction.Fact(N) / WorksheetFunction.Fact(N - K)
ReDim ar(1 To K)
For j = 1 To K
ar(j) = j
Next
CheckVal 1, K, ar
' Debug.Print i; ":";: For j = 1 To k: Debug.Print ar(j);: Next: Debug.Print
For i = 2 To lngSize
arIncNoDup ar, N, K, K
CheckVal i, K, ar
' Debug.Print i; ":";: For j = 1 To k: Debug.Print ar(j);: Next: Debug.Print
Next
End Sub
Private Sub arIncNoDup(ByRef ar() As Long, ByVal N As Integer, ByVal K As Integer, ByVal _
intSpalte As Integer)
Dim j As Integer, l As Integer, m As Integer
ReDim arInUse(0 To N)
For j = 1 To K
If j  intSpalte Then arInUse(ar(j)) = 1
Next
For j = ar(intSpalte) + 1 To N
If arInUse(j)  1 Then
ar(intSpalte) = j
arInUse(j) = 1
For l = intSpalte + 1 To K
For m = 1 To K
If arInUse(m) = 0 Then
ar(l) = m
arInUse(m) = 1
Exit For
End If
Next m
Next l
Exit Sub
End If
Next
For j = intSpalte To K
ar(j) = 0
Next
arIncNoDup ar, N, K, intSpalte - 1
End Sub
Private Sub CheckVal(ByVal i As Long, ByVal K As Integer, ByRef x() As Long)
Static lngZeile As Long
Dim v(1 To 20) As Long, v2 As Long, v3 As Long, v4 As Long, v5 As Long, v6 As Long, v7 As  _
Long, v8 As Long
Dim v9 As Long, v10 As Long, v11 As Long, v12 As Long, v13 As Long, v14 As Long, v15 As Long, _
v16 As Long
Dim v17 As Long, v18 As Long, v19 As Long, v20 As Long
Dim A As Long, B As Long, C As Long, D As Long, E As Long, F As Long, G As Long, H As Long
'  Die Aufgabe die es zu lösen gilt
'    |   1      2      3      S
'  1 | ABCB - BDEF + GHAH = DABA
'  2 | GDCH /  F   *  H   = FABE
'  3 | HCHG +  AC  - DAFC = GEGG
'  S | HDGE - FCDA + HFHB = BAGC
' ABCB - BDEF + GHAH = DABA
' A=1,B=2,C=3,D=4,E=5,F=6,G=7,H=8
' In x(i) steht 1...10, das auf 0...9 umbiegen
A = x(1) - 1
B = x(2) - 1
C = x(3) - 1
D = x(4) - 1
E = x(5) - 1
F = x(6) - 1
G = x(7) - 1
H = x(8) - 1
'erste Zeile berechnen, da hier alle Variablen vorkommen
v(1) = 1000 * A + 100 * B + 10 * C + B
v(2) = 1000 * B + 100 * D + 10 * E + F
v(3) = 1000 * G + 100 * H + 10 * A + H
v(4) = 1000 * D + 100 * A + 10 * B + A           'Ergebnis Zeile 1
If v(1) - v(2) + v(3) = v(4) Then                'Zahlen von Ergebnis mit Rechenoperation  _
vergleichen
'Wenn der Vergleich positiv ist alle weiteren Zeilen und Spalten durchrechnen
If Not (F = 0 Or H = 0) Then                    'Ausschließen, dass Buchstabe F und H = 0  _
ist
v(5) = 1000 * G + 100 * D + 10 * C + H
v(6) = F
v(7) = H
v(8) = v(5) / v(6) * v(7)                   'Ergebnis Zeile 2
v(9) = 1000 * H + 100 * C + 10 * H + G
v(10) = 10 * A + C
v(11) = 1000 * D + 100 * A + 10 * F + C
v(12) = v(9) + v(10) - v(11)                'Ergebnis Zeile 3
v(16) = v(4) + v(8) - v(12)                 'Endsumme Zeile 1 - 3 Ergebnisse - BAGC
v(17) = v(1) + v(5) - v(9)                  'Ergebnis Spalte 1
v(18) = v(2) / v(6) + v(10)                 'Ergebnis Spalte 2
v(19) = v(3) / v(7) + v(11)                 'Ergebnis Spalte 3
v(20) = v(17) - v(18) + v(19)               'Endsumme Spalte 1 - 3 Ergebnisse - BAGC
If ((v(16)  999) And (v(20)  999)) Then 'nur  _
veistellige Ergebnisse zulassen
lngZeile = lngZeile + 1
Cells(lngZeile, 1).Value = A & B & C & D & E & F & G & H
Cells(lngZeile, 2).Value = v(16)
Cells(lngZeile, 3).Value = v(20)
End If
End If
End If
'lngZeile = 0
End Sub

Option Explicit Sub x() Dim i As Long Dim A As Long, B As Long, C As Long, D As Long, E As Long, F As Long, G As Long, H As Long ' Die Aufgabe die es zu lösen gilt ' F5 F6 F7 F8 ' F1 ABCB - BDEF + GHAH = DABA ' F2 GDCH / F * H = FABE ' F3 HCHG + AC - DAFC = GEGG ' F4 HDGE - FCDA + HFHB = BAGC Dim v(1 To 4, 1 To 4) As Long i = 10 Cells(10, 1).Resize(, 16).Value = Array("A", "B", "C", "D", "E", "F", "G", "H", "F1", "F2", " _ F3", "F4", "F5", "F6", "F7", "F8") For A = 0 To 9 For B = 0 To 9 For C = 0 To 9 For D = 0 To 9 For E = 0 To 9 For F = 1 To 9 For G = 0 To 9 For H = 1 To 9 v(1, 1) = 1000 * A + 100 * B + 10 * C + B v(1, 2) = 1000 * B + 100 * D + 10 * E + F v(1, 3) = 1000 * G + 100 * H + 10 * A + H v(1, 4) = 1000 * D + 100 * A + 10 * B + A v(2, 1) = 1000 * G + 100 * D + 10 * C + H v(2, 2) = F v(2, 3) = H v(2, 4) = 1000 * F + 100 * A + 10 * B + E v(3, 1) = 1000 * H + 100 * C + 10 * H + G v(3, 2) = 10 * A + C v(3, 3) = 1000 * D + 100 * A + 10 * F + C v(3, 4) = 1000 * G + 100 * E + 10 * G + G v(4, 1) = 1000 * H + 100 * D + 10 * G + E v(4, 2) = 1000 * F + 100 * C + 10 * D + A v(4, 3) = 1000 * H + 100 * F + 10 * H + B v(4, 4) = 1000 * B + 100 * A + 10 * G + C If v(1, 1) - v(1, 2) + v(1, 3) = v(1, 4) Then i = i + 1 Cells(i, 1).Resize(, 9) = Array(A, B, C, D, E, F, G, H, 1) Cells(i, 10) = IIf(v(2, 1) / v(2, 2) * v(2, 3) = v(2, 4), 1, 0) Cells(i, 11) = IIf(v(3, 1) + v(3, 2) - v(3, 3) = v(3, 4), 1, 0) Cells(i, 12) = IIf(v(4, 1) - v(4, 2) + v(4, 3) = v(4, 4), 1, 0) Cells(i, 13) = IIf(v(1, 1) + v(2, 1) - v(3, 1) = v(4, 1), 1, 0) Cells(i, 14) = IIf(v(1, 2) / v(2, 2) + v(3, 2) = v(4, 2), 1, 0) Cells(i, 15) = IIf(v(1, 3) / v(2, 3) + v(3, 3) = v(4, 3), 1, 0) Cells(i, 16) = IIf(v(1, 4) + v(2, 4) - v(3, 4) = v(4, 4), 1, 0) End If Next H Next G Next F Next E Next D Next C Next B Next A End Sub

…Jungs…?
Das ist doch so etwas wie ein lineares Gleichungssystem mit 8 Unbekannten und 8 Gleichungen. Leider ist das schon sehr lange her und ich bekomme das nicht mehr so recht zusammen. Aber, falls ich mich nicht irgendwo geirrt haben sollte, kämen doch ff Gleichungen dabei heraus:
F1: (10³a+10²b+10c+b)-(10³b+10²d+10e+f)+(10³g+10²h+10a+h)=10³d+10²a+10b+a
F2: ((10³g+10²d+10c+h)/f)*h=10³f+10²a+10b+e
F3: (10³h+10²c+10h+g)+(10a+c)-(10³d+10²a+10f+c)=10³g+10²e+10g+g
F4: (10³h+10²d+10g+e)-(10³f+10²c+10d+a)+(10³h+10²f+10h+b)=10³b+10²a+10g+c
F5: (10³a+10²b+10c+b)+(10³g+10²d+10c+h)-(10³h+10²c+10h+g)=10³h+10²d+10g+e
F6: (10³b+10²d+10e+f)/f+(10a+c)=10³f+10²c+10d+a
F7: (10³g+10²h+10a+h)/h+(10³d+10²a+10f+c)=10³h+10²f+10h+b
F8: (10³d+10²a+10b+a)+(10³f+10²a+10b+e)-(10³g+10²e+10g+g)=10³b+10²a+10g+c
Die könnte man wohl (Irrtum nicht ausgeschlossen!) so vereinfachen:
F1: 909a-909b+10c-1100d-10e-f+1000g+101h=0
F2: -100a-10b+10ch/f+100dh/f-e-1000f+1000gh/f+h²/f=0
F3: -90a+100c-1000d-100e-10f-1010g+1010h=0
F4: -101a-999b-101c+90d+e-900f+2010h=0
F5: 1000a+101b-80c-e+989g-2009h=0
F6: 9a+1000b/f-99c-10d+100d/f+10e/f-1000f+1=0
F7: 100a+10a/h-b+c+1000d-90f+1000g/h-1010h+101=0
F8: 101a-980b-c+1000d-99e+1000f-1021g=0
Evtl könnte man auch noch ff 15 Variablen definieren:
i:=b/f, j:=d/f, k:=e/f, l:=f/f, m:=a/h, n:=g/h, o:=h/h, p:=ch, q:=dh, r:=gh, s:=hh, t:=p/f, u:=q/f, v:=r/f, w:=s/f
Morrn, Luc :-?
Besser informiert mit …

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread