Prozedur optimieren
20.07.2013 09:11:21
alifa
ich hoffe, die Gemeinschaft nicht überzustrapazieren! Das ist jetzt die letzte Frage, zunächst. Hier habe ich eine Prozedur,die eine Tabelle, wo in den Spalten 8 bis 23 sechzehn Werte stehen. Die Prozedur versucht, aus diesen 16 Zahlen(größter Wert 409), ein magisches Quadrat zu ermitteln. Mein Rechner braucht etwa 7 Sekunden pro Zeile.
Die Notation, wie beim Schachbrett. Kann das noch optimiert werden?
Gruß, Erhard
Sub MagischesQuadrat4x4() 'bis jetzt am schnellsten!
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, 8), Cells(lngZeile, 23))
m = 490
'Diagonale a1-d4
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 'summe 1
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 'summe 2
'Diagonale d1-a4
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
If b3 + c3 + b2 + c2 = m Then 'summe 3
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 'summe 4
If a1 + d1 + d4 + a4 = m Then ' summe 5
For Each a3 In p
If Va(a3, Array(a4, b3, c2, d1, d2, d3, d4, c3, b2, a1)) Then
If a3 + b3 + c3 + d3 = m Then 'summe 6
For Each a2 In p
If Va(a2, Array(a3, a4, b3, c2, d1, d2, d3, d4, c3, b2, a1)) Then
If a2 + b2 + c2 + d2 = m Then 'summe 7
If a4 + a3 + a2 + a1 = m Then 'summe 8
If a3 + a2 + d3 + d2 = m Then 'summe 9
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 'summe 10
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 'summe 11
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 'summe 12
If b1 + c1 + b4 + c4 = m Then 'summe 13
If a4 + b4 + c4 + d4 = m Then 'summe 14
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: End If: Next: End If: End If: Next b4
End If: End If: Next: End If: Next b1
End If: End If: End If: End If: Next: End If: End If: Next a3
End If: End If: End If: Next: End If: 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