Optimieren
14.07.2013 19:28:39
alifa
Die Prozedur soll ein magisches Quadrat 4x4 ermitteln. Die 16 Zahlen sind vorgegeben.
Testen kann man mit den 16 Primzahlen 31-101 mit der magischen Summe 258. Kann das noch optimiert werden? Kennt jemand eine schnellere Prozedur?
Option Explicit
Sub MagQuadrat4()
Dim a1, b1, c1, d1, a2, b2, c2, d2, a3, b3, c3, d3, a4, b4, c4, d4
Dim p, m, lngZeile&, zeileMax&
Dim z%, t!
t = Timer
'Cells.ClearContents
zeileMax = ActiveSheet.UsedRange.Rows.Count
For lngZeile = 1 To zeileMax
p = Range(Cells(lngZeile, 1), Cells(lngZeile, 16))
m = Cells(lngZeile, 18)
'Diagonale
For Each a1 In p
For Each b2 In p
If b2 a1 Then
For Each c3 In p
If c3 b2 And c3 a1 Then
For Each d4 In p
If Va(d4, Array(c3, b2, a1)) Then
If a1 + b2 + c3 + d4 = m Then
For Each d3 In p
If Va(d3, Array(d4, c3, b2, a1)) Then
For Each d2 In p
If Va(d2, Array(d3, d4, c3, b2, a1)) Then
For Each d1 In p
If Va(d1, Array(d2, d3, d4, c3, b2, a1)) Then
If d4 + d3 + d2 + d1 = m Then
For Each c2 In p
If Va(c2, Array(d1, d2, d3, d4, c3, b2, a1)) Then
For Each b3 In p
If Va(b3, Array(c2, d1, d2, d3, d4, c3, b2, a1)) Then
For Each a4 In p
If Va(a4, Array(b3, c2, d1, d2, d3, d4, c3, b2, a1)) Then
If d1 + c2 + b3 + a4 = m Then
If a1 + d1 + d4 + a4 = m Then
For Each a3 In p
If Va(a3, Array(a4, b3, c2, d1, d2, d3, d4, c3, b2, a1)) Then
For Each a2 In p
If Va(a2, Array(a3, a4, b3, c2, d1, d2, d3, d4, c3, b2, a1)) Then
If a4 + a3 + a2 + a1 = m Then
If a3 + a2 + d3 + d2 = m Then
For Each b1 In p
If Va(b1, Array(a2, a3, a4, b3, c2, d1, d2, d3, d4, c3, b2, a1)) Then
For Each c1 In p
If Va(c1, Array(b1, a2, a3, a4, b3, c2, d1, d2, d3, d4, c3, b2, a1)) Then
If a1 + b1 + c1 + d1 = m Then
For Each b4 In p
If Va(b4, Array(c1, b1, a2, a3, a4, b3, c2, d1, d2, d3, d4, c3, b2, a1)) Then
If b1 + b2 + b3 + b4 = m Then
For Each c4 In p
If Va(c4, Array(b4, c1, b1, a2, a3, a4, b3, c2, d1, d2, d3, d4, c3, b2, a1)) Then
If c1 + c2 + c3 + c4 = m Then
If b1 + c1 + b4 + c4 = m Then
MsgBox a1 & "," & b1 & "," & c1 & "," & d1 & "," & a2 & "," & b2 & "," & c2 & "," & d2 & "," & _
_
a3 & vbLf & _
b3 & "," & c3 & "," & d3 & "," & a4 & "," & b4 & "," & c4 & "," & d4 & vbLf & Round(Timer - t, _
_
1) & "" & "Sek"
MsgBox Round(Timer - t, 1)
End If: End If: End If: Next: End If: End If: Next b4
End If: End If: Next: End If: Next b1
End If: End If: End If: Next: End If: Next a3
End If: End If: End If: Next: End If: Next: End If: Next c2
End If: End If: Next: End If: Next: End If: Next d3
End If: End If: Next: End If: Next: End If: Next: Next a1
Next lngZeile
MsgBox Round(Timer - t, 1)
End Sub
Function Va(ByVal z1, arrWerte) As Boolean 'z1 verschieden mit allen Werten aus Array
Dim i As Byte
For i = 0 To UBound(arrWerte) - 1
If z1 = arrWerte(i) Then Exit Function
Next
If z1 arrWerte(i) Then Va = True
End Function
Gruß, alifa