Löschen ist falsch, bringt aber eh nichts
06.06.2009 19:49:55
Erich
Hi Erhard,
in deiner Losch-Routine haben Zeile und Spalte (das könnten auch ganz andere Variablennamen sein)
nichts zu tun damit, welche Zelle gepfrüft oder welche Zeile gelöscht wird.
Geprüft wird immer die (zufällig gerade) aktive Zelle.
Die beiden Schleifen über Zeile und Spalte führen nur dazu, dass der Schleifenkörper
If (Mid(ActiveCell.Value, 1, 1)) = "0" Then
Selection.EntireRow.Delete
End If
20 * 9300 = 186000 mal ausgeführt wird.
Ab der ersten aktiven Zelle, an deren 1. Stelle keine "0" steht, ändert sich nichts mehr.
Wenn der Cursor vor dem Makroaufruf in A1 steht, werden die ersten 2636 Zeilen gelöscht,
in denen in Spalte A die Lösungen In anderen Spalten prüft dein Makro nicht!
Stünde der Cursor vor dem Makroaufruf in B1, würde sich überhaupt nichts verändern an der Tabelle.
Damit würdest du das Gleiche (nur schneller) erreichen:
Sub Loesch0()
Dim ii As Long, t As Single
Application.EnableEvents = False
Application.ScreenUpdating = False
For ii = 1 To 2700
If (Mid(ActiveCell.Value, 1, 1)) = "0" Then
Selection.EntireRow.Delete
End If
Next
Application.EnableEvents = True
MsgBox "Fertig nach " & Round(Timer - t, 2) & " Sekunden"
End Sub
Hier eine Routine, die in allen relevanten Zeilen und Spalten sucht:
Option Explicit
Sub Loesch()
Dim Zeile As Long, Spalte As Long, t As Single
Application.EnableEvents = False
Application.ScreenUpdating = False
t = Timer
For Zeile = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1
For Spalte = 1 To 8
If Left(Cells(Zeile, Spalte).Value, 1) = "0" Then
Rows(Zeile).Delete
Exit For
End If
Next Spalte
Next Zeile
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "Fertig nach " & Round(Timer - t, 2) & " Sekunden"
End Sub
Diese Routine löscht 4620 von den 9264 Lösungen, 4644 Lösungen bleiben erhalten.
Aber: Dabei werden auch Lösungen gelöscht, die nach der engeren Definition zulässig sind!
Beispiel:
In der Liste mit den 9264 Lösungen (mit den Nullen) gibt es die Lösung
1420385967 14 420 0385 14203 420385 2038596 20385967 142038596
Sie wird wegen der 0 am Anfang von 0385 gelöscht.
Lässt man gleich nach Lösungen suchen, bei denen keine führenden Nullen vorkommen,
wird die Lösung
1420385967 14 420 8596 14203 420385 2038596 20385967 142038596
gefunden.
Sie ist sicher zulässig - 8596 ist eben eine weitere 4stellige durch 7 teilbare Teilzahl.
Man darf also nicht einfach löschen, sondern müsste auch prüfen,
ob anstelle einer nicht zulässigen Teilzahl eine andere zulässig ist,
sonst löscht man zu viele Lösungen.
So findet man direkt die 4840 Lösungen ohne führende Nullen:
Option Explicit
Sub Teiler7() ' 3628800 Permutationen, davon sind 9264 Lösungen
Dim zz As Long, arrE(1 To 3628800) As String, ii As Integer, pp As Integer
Dim arrV(1 To 10) As Integer, nn As Long, arrW(1 To 8) As String, dblT As Double
Const tt As String = "0123456789"
Application.StatusBar = False
Perm tt, "", zz, arrE() ' 3628800 Permutationen werden in arrE abgelegt
Columns(1).NumberFormat = "@"
For zz = 1 To 3628800 ' Schleife über die 3628800 Permutationen
For ii = 10 To 2 Step -1 ' ii steht für die Länge (10 bis 2) der Teilzahlen
For pp = 1 To 11 - ii ' pp steht für die Position der Teilzahl
If Mid(arrE(zz), pp, 1) > "0" Then
dblT = CDbl(Mid(arrE(zz), pp, ii)) ' Teilzahl als Double
If dblT = 7 * Fix(dblT / 7) Then ' Ist Teilzahl teilbar durch 7?
arrV(ii) = 1 ' Länge ii erledigt
' arrW(ii-1): gefundene Teilzahl als Text
If 1 = 9 Then ' Wurden alle 9 Längen (10 bis 2) erledigt?
nn = nn + 1 ' Wenn ja, neue Zeilennr.
Cells(nn, 1) = arrE(zz) ' Eintragen der Lösung arrE(zz)
Cells(nn, 2).Resize(, 8) = arrW ' Teilzahlen der Lösung in Spalten 2-9 (B:I)
For ii = 1 To 8
Cells(nn, ii + 10) = CDbl(arrW(ii)) / 7 ' Quotienten in Spalten 11-18 (K:R)
Next ii
Cells(nn, ii + 10) = arrE(zz) / 7 ' Lösung / 7 in Spalte 19 (S)
End If
Erase arrV, arrW
Application.StatusBar = zz & " / " & arrE(zz)
DoEvents
Next zz
Application.StatusBar = False
End Sub
Sub Perm(aa As String, bb As String, Ze As Long, arrX() As String)
Dim ii As Long, jj As Long
jj = Len(aa)
If jj > 1 Then
For ii = 1 To jj
Perm Left(aa, ii - 1) + Right(aa, jj - ii), bb + Mid(aa, ii, 1), Ze, arrX()
Next ii
Else
Ze = Ze + 1
arrX(Ze) = bb & aa
End If
End Sub
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort