Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Prozedur optimieren

Betrifft: Prozedur optimieren von: alifa
Geschrieben am: 20.07.2013 09:11:21

Hallo,
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 

  

Betrifft: AW: Prozedur optimieren von: Hajo_Zi
Geschrieben am: 20.07.2013 09:36:14

es reicht ein Beitrag in Offen.

GrußformelHomepage


  

Betrifft: AW: Prozedur optimieren von: alifa
Geschrieben am: 20.07.2013 17:53:14

Hi,
habe die Lösung gefunden, indem ich die Reihenfolge der Ermittlungen geändert habe. in 12,3 Sekunden kam die erste Lösung!
Ich wünsche Allen ein angenehmes Wochenende!
Erhard


 

Beiträge aus den Excel-Beispielen zum Thema "Prozedur optimieren"