Wenn in Spalte C keine Füllfarbe, dann ganze Zeile löschen

[RPP63]

Moin!

Zunächst Generierung von 200.000 zufälligen Daten hiermit (Laufzeit ca. 21 Sek. - schnarch)

Mach mal so:

Sub Zufallszahlen()
Dim Start#
Application.ScreenUpdating = False
Start = Timer
Columns(1).ClearContents
Range("A1") = "ArtNr"
With Range("A2:A200001")
   .Formula = "=Randbetween(1,50000)"
   .Copy: .PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
Application.Goto Cells(1)
Debug.Print Timer - Start
End Sub

Dauert auf meinem alten Notebook 0,49 Sekunden.

Ergänzend:
Meine Formel in #8 ist falsch!
Ausgebessert in
.Formula = "=IF(($A2>$A1)*($A3>$A2),1,ROW())"

Laufzeit: 2,25 Sekunden

Ich teste aber mal eure beiden Ansätze, ob die schneller sind (ist ja in hohem Maße von der Hardware abhängig).

Gruß Ralf

[IchBinIch]

Hallo Ralf,

das ist deutlich schneller!
0,18359375 Sek. auf meinem brandneuen Laptop.

Da hätte ich auch selbst drauf kommen können, dass alles schreiben und dann alles als Werte einfügen schneller sein muss .
Danke. Wieder was gelernt :32:

Gruß
Ich

[Fennek]

@ IchbinIch

Hallo,

beim Versuch den Code auf meinem xl2016 Rechner zu testen, gab es eine Fehlermeldung:

Code:

Set cn = CreateObject("ADODB.CONNECTION")

strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; DBQ=" & ThisWorkbook.FullName

Set cn = New ADODB.Connection   '<<<<<<<<<<<<< Fehler

Auch meine Versuche einen Verweis zu setzen, waren nicht erfolgreich. Darf ich einmal nachfragen?

(bisher habe ich um RegEx und ADO einen Bogen gemacht)

mfg

[Fennek]

Hallo,

noch ein speed test auf einen neuen PC:

Mein letzer Code mit Zeilen löschen war extrem langsam, aber mit der Auswahl kopieren kam es auf 1,15 Sekunden.

Hier der Code:

Code:

Sub BereichMitZufallszahlenFüllen()
Dim Zelle As Range
Dim Bereich As Range
Dim Start As Single
Dim Ende As Single
Dim Laufzeit As Single

Start = Timer()

With Tabelle1
   .Range("A:C").ClearContents
   Set Bereich = .Range("C2:C200001")
   .Range("A1").Value = "ArtikelNr"
   'For Each Zelle In Bereich
 
       Bereich.Formula = "=Randbetween(1,50000)"
       'Zelle.Formula = "=Randbetween(1,50000)"
       'Zelle.Value = Zelle.Value
       Bereich.Copy
       Bereich.PasteSpecial xlPasteValues
 
  'Next Zelle
End With

Ende = Timer()
Laufzeit = Ende - Start

Debug.Print Laufzeit

End Sub


###########################################
Sub Test()
Start = Timer
Dim Res

Application.DisplayAlerts = False
With CreateObject("scripting.dictionary")
ar = Application.Transpose(Range("C1:C59879"))
'Debug.Print ar(1), ar(2)
ReDim Res(LBound(ar) To UBound(ar))

For i = 1 To UBound(ar)
   If .exists(ar(i)) Then
       Res(i) = 1
   Else
   y = .Item(ar(i))
   Res(i) = 0
   End If
Next i
Debug.Print "Nach Dict: " & Timer - Start ' <<<<<<<<<<< 0,09 Sekunden
Cells(1, "D").Resize(UBound(ar)) = Application.Transpose(Res)
End With
Cells(1, "D") = "T4"
With Cells(1).CurrentRegion
.AutoFilter 4, 0
Debug.Print "Nach Autofilter: " & Timer - Start '<<<<<<<<<<<<< weitere 0,09 Sekunden, zusammen 0, 18
.Copy Sheets(3).Cells(1, 1)
'.Offset(1).EntireRow.Delete  <<<<<<<<<<<<<<<<< dauerte ca 40 Sekunden
.AutoFilter
End With
Application.DisplayAlerts = True
Debug.Print "Komplett: " & Timer - Start

End Sub

mfg

[IchBinIch]

Hallo Fennek,

klar darfst Du fragen. 
Unter Verweise "Microsoft ActiveX Objects 2.8" aktivieren. 
Getestet habe ich den Code unter Office 365 das sollte also passen.

Gruß
Ich

[IchBinIch]

Hallo,

noch ein speed test auf einen neuen PC:

Mein letzer Code mit Zeilen löschen war extrem langsam, aber mit der Auswahl kopieren kam es auf 1,15 Sekunden.

Hier der Code:

Code:

Sub BereichMitZufallszahlenFüllen()
Dim Zelle As Range
Dim Bereich As Range
Dim Start As Single
Dim Ende As Single
Dim Laufzeit As Single

Start = Timer()

With Tabelle1
   .Range("A:C").ClearContents
   Set Bereich = .Range("C2:C200001")
   .Range("A1").Value = "ArtikelNr"
   'For Each Zelle In Bereich
 
       Bereich.Formula = "=Randbetween(1,50000)"
       'Zelle.Formula = "=Randbetween(1,50000)"
       'Zelle.Value = Zelle.Value
       Bereich.Copy
       Bereich.PasteSpecial xlPasteValues
 
  'Next Zelle
End With

Ende = Timer()
Laufzeit = Ende - Start

Debug.Print Laufzeit

End Sub


###########################################
Sub Test()
Start = Timer
Dim Res

Application.DisplayAlerts = False
With CreateObject("scripting.dictionary")
ar = Application.Transpose(Range("C1:C59879"))
'Debug.Print ar(1), ar(2)
ReDim Res(LBound(ar) To UBound(ar))

For i = 1 To UBound(ar)
   If .exists(ar(i)) Then
       Res(i) = 1
   Else
   y = .Item(ar(i))
   Res(i) = 0
   End If
Next i
Debug.Print "Nach Dict: " & Timer - Start ' <<<<<<<<<<< 0,09 Sekunden
Cells(1, "D").Resize(UBound(ar)) = Application.Transpose(Res)
End With
Cells(1, "D") = "T4"
With Cells(1).CurrentRegion
.AutoFilter 4, 0
Debug.Print "Nach Autofilter: " & Timer - Start '<<<<<<<<<<<<< weitere 0,09 Sekunden, zusammen 0, 18
.Copy Sheets(3).Cells(1, 1)
'.Offset(1).EntireRow.Delete  <<<<<<<<<<<<<<<<< dauerte ca 40 Sekunden
.AutoFilter
End With
Application.DisplayAlerts = True
Debug.Print "Komplett: " & Timer - Start

End Sub

mfg

Hallo Fennek,

ich habe auch eine Frage.
Du füllst den Bereich bis C200001.
Liest aber nur einen Teil ein?
ar = Application.Transpose(Range("C1:C59879"))

Gruß
Ich

Und noch was...
Erstellt man damit nicht schon automatisch ein Unikatsverzeichnis?

CreateObject("scripting.dictionary")

Ich meine das mal irgendwo gelesen zu haben.

[Fennek]

Hallo,

gestern nutzte ich einen Rechner XP mit xl2003 und da mir die Schleife zu lange dauerte, habe ich den Rest per Hand ausgefüllt. Daher die 59...

Heute nutzte ich eine Win 8.1 mit xl 2016 und habe gewartet, bis die Schleife fertig war (im direkten Vergleich war den "neue" 47xx dreimal schneller als ein 12 Jahre alter Laptop)

Frage 2: je nach Programmierung kann man mit Dictionary Unikate erstellen. Hier im Beispiel sollte alle Unikate gelöscht werden, also umgekehrt zu den üblichen "removeDuplicates".

Ich habe deinen Code so verstanden, dass er die Zählenwenn-Funktion nachbaut, aber keine Zeilen löscht.


mfg

vielen Dank für die Info zum Verweis

[IchBinIch]

Hallo Fennek,

Danke für die Antwort.
Ja richtig. Ich erstelle im ersten Sub eine Zusammenstellung aller Artikel und gebe die Anzahl "Treffer" in Spalte C aus.
Im zweiten Sub nutze ich dieses Ergebnis und übertrage alle Artikel, die öfter als einmal vorkommen in Tabelle 2.
Ich dünne also aus wenn man so will, ohne Daten zu löschen. Weg ist weg und das mag ich nicht :32:

Gruß
Ich

[RPP63]

N'Abend!   :19:

Da hätte ich auch selbst drauf kommen können, dass alles schreiben und dann alles als Werte einfügen schneller sein muss 

Nicht nur dies!
(Ich bleibe mal beim "Quasi-Off-Topic", ist aber durchaus interessantes Grundlagenwissen)

Dieses .Value = .Value hat sich als ultra schlechte Variante eingebürgert!
Wohl nur, weil es schnell zu schreiben ist?
In der Performance ist es grottenschlecht!

Teste mal auf der schnellen Maschine (jetzt bin es ich, der *schnüff* sagen muss) folgendes Makro RPP:

Sub RPP()

Dim Start#, Dauer1#, Dauer2#

Call Zufallszahlen

Start = Timer

Range("A2:A200001").Value = Range("A2:A200001").Value

Dauer1 = Timer - Start

Call Zufallszahlen

Start = Timer

Range("A2:A200001").Copy

Range("A2:A200001").PasteSpecial xlPasteValues

Application.Goto Range("A1")

Dauer2 = Timer - Start

Debug.Print _

  ".Value = .Value dauert: " & Format(Dauer1, "0.000 sec.") & vbLf & _

  ".PasteSpecial dauert: " & vbTab & Format(Dauer2, "0.000 sec.") & vbLf & _

  "und ist damit " & vbTab & vbTab & vbTab & vbTab & _

     Format(Dauer1 / Dauer2, "0.000") & "-mal schneller!"

End Sub



Sub Zufallszahlen()

Columns(1).ClearContents

Range("A1") = "ArtNr"

Range("A2:A200001").Formula = "=Randbetween(1,500000)"

End Sub

Mein Direktfenster meldet:

Code:

.Value = .Value dauert: 1,563 sec.
.PasteSpecial dauert:   0,219 sec.
und ist damit           7,143-mal schneller!

Gruß Ralf

[Fennek]

@RPP63

"IchBinIch" hat 0,18 Sekunden genannt (weiter oben auf Seite 2) und das kann ich bestätigen.

Ich hatte den Eindruck, dass xl den theoretischen Vorteil schnelleren PC nur zum kleinen Teil realisieren kann: alt gegen neu "nur" ca ein Faktor 3, nach dem Moore' "Gesetz" sollten es aber 2 hoch 5 sein. Die Art der Programmierung ist wesentlich entscheidender: mein letzt genannter Code braucht mit copy anstelle delete ca 1,6 Sekunden für 200.000 Zeilen.

mfg

PS: es ist zwar "olympisch" immer schneller sein zu wollen, aber ob ein Code 1 oder 2 Sekunden braucht, ist eigentlich vollkommen egal. Nicht so, ob ein Code 20 Minuten anstelle 5 Sekunden braucht.

(der Vergleich mit Olympia sollte niemanden beleidigen)