Hallo zusammen,
ich suche nach einer Lösung für folgendes Problem:
Ich habe eine Tabelle mit 200 000 Zeilen und 5 Spalten. In der Spalte C sind doppelte Werte über die
bedingte Formatierung mit einer Füllfarbe markiert.
Ich möchte nun alle Zeilen löschen, bei denen in Spalte C kein doppelter Wert (also keine Füllfarbe)
vorhanden ist.
Man könnte ja nach Farbe filtern und dann löschen, aber wegen der Größe der Tabelle ist das sehr zähflüssig.
Kann man sowas über evtl. über ein Makro lösen, welches dann alleine läuft?
Meine VBA-Kenntnisse sind leider noch sehr dürftig.
Für einen Tipp wäre ich dankbar.
Freundliche Grüße
Jürgen
Hallo,
die Farbe aus einer bedingten Formatierung kann man erst ab xl2013 auslesen. Außerdem dauert Löschen einzelner Zeilen in einer so großen Datei "ewig".
Eine Hilfsspalte mit der Bedingung und dann alle doppelten Zeilen auf einmal löschen, sollte der bessere Weg sein.
mfg
Hallo Fennek,
danke für deine schnelle Antwort.
Ich habe die Excel-Versionen 2013 und 2016 zur Verfügung.
Das die Sache dauern wird ist mir klar. Deshalb dachte ich ja, ein Makro könnte erst mal "alleine"
laufen. Das der Rechner dann eine Weile blockiert ist spielt erst mal keine Rolle.
Wie könnte man das denn mit einer Hilfsspalte und einer Formel lösen?
Ich habe schon mal mit "Identisch" herumprobiert, aber dann erhalte ich n x Wahr und n x Falsch
und wenn man das mit "Doppelte Werte entfernen" bearbeitet würden auch Zeilen gelöscht die ich behalten will.
Die Werte um die es geht steht alle in Spallte C. Es gibt viele die doppelt sind und noch viel mehr die
nicht doppelt sind.
Ich möchte die doppelten behalten und zwar beide Zeilen (diese unterscheiden sich dann in einer anderen
Spalte) und die eindeutigen löschen.
Freundliche Grüße
Jürgen
Hallo,
mit =zählenwenn() kann man Doppelte (oder auch mehrfache) von eindeutigen unterscheiden.
mfg
Hallo Jürgen,
nachfolgend ein Makro, das ohne auf die Formatierung rücksicht zu nehmen alle doppelten Einträge löscht.
Ich gehe davon aus, dass Deine Tabelle Überschriften hat.
Code:
Sub DuplikateLöschen()
Dim z As Long
Dim zm As Long
'eventuell die Tabelle anpassen
With Tabelle1
zm = .UsedRange.Rows.Count
For z = zm To 2 Step -1
If Application.WorksheetFunction.CountIf(.Columns(3), .Cells(z, 3).Value) > 1 Then
.Rows(z).Delete
End If
Next z
End With
End Sub
Gruß
Ich
Moin!
Wobei Zählnwenn bei einer derartig großen Tabelle zu rechenintensiv sein dürfte.
Bin mom nicht am Rechner, so etwas müsste aber mit einem anderen Ansatz sehr schnell gehen.
Bis später, Ralf
Ich lese gerade Deine Antwort an Fennek
Wenn Du die Unikate löschen willst müsstest Du das so ändern:
Code:
If Application.WorksheetFunction.CountIf(.Columns(3), .Cells(z, 3).Value) = 1 Then
.Rows(z).Delete
End If
Aber wie Ralf schon schrieb, das geht auch schneller über einen Array.
Gruß
Ich
Hi Du! :19:
Nö, kein Array, sondern reine Excel-Boardmittel:
- Spalte C sortieren
- in eine freie Spalte Zeile 1: 1 (als "Überschrift"), ab 2 die Formel: =WENN($A1<>$A2;0;ZEILE())
- Hilfsspalte kopieren und als Wert einfügen
- auf Hilfsspalte Duplikate entfernen anwenden
- Hilfsspalte löschen
Mein Beispiel bezieht sich nur auf die mit 200.000 Werten gefüllte Spalte A (incl. Header), die Hilfsspalte ist Spalte B:
Es werden 20.629 Unikate entfernt.
Laufzeit: 2,883 Sekunden.
Wer kann schneller?
:21:
Sub RPP()
Dim Start#
Application.ScreenUpdating = False
Start = Timer
With ActiveSheet
.UsedRange.Sort Range("A2"), xlAscending, Header:=xlYes
.Cells(1, 2) = 1
With .Range(.Cells(2, 2), .Cells(2, 1).End(xlDown).Offset(0, 1))
.FormulaR1C1 = "=IF(R[-1]C1<>RC1,0,ROW())"
.Copy: .Cells(2, 2).Offset(-1, -1).PasteSpecial xlPasteValues
End With
.UsedRange.RemoveDuplicates 2, xlYes
.Columns(2).Delete
End With
Debug.Print Timer - Start
End Sub
Gruß Ralf
Hallo,
ohne den Ansatz von RPP63 zu kennen, ein Versuch einen flotten Code zu schreiben.
Getestet mit 60.000 Zeilen, Doppelte in Spalte C, Hilfsspalte in D. Auf einem alterschwachen Laptop: 0,6 Sekunden
Code:
Sub setzen()
Dim i As Long
j = 2
For i = 65 To 65 + 25
Cells(j, "C") = Chr(i)
j = j + 1
Next i
Range("C2:C27").Copy
For i = 28 To 60000 Step 26
Cells(i, "C").PasteSpecial
Next i
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))
End If
Next i
Cells(1, "D").Resize(UBound(ar)) = Application.Transpose(Res)
End With
With Cells(1).CurrentRegion
.AutoFilter 4, 1
.Offset(1).EntireRow.Delete
.AutoFilter
End With
Application.DisplayAlerts = True
MsgBox Timer - Start
End Sub
mfg
(17.09.2016, 15:21)RPP63 schrieb: [ -> ]...
Wer kann schneller?
:21:
...
Ob das noch Boardmittel sind...
Naja ist ja mit Excel möglich :32: :21:
Zunächst Generierung von 200.000 zufälligen Daten hiermit (Laufzeit ca. 21 Sek. - schnarch)
PHP-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("A2:A200001")
.Range("A1").Value = "ArtikelNr"
For Each Zelle In Bereich
Zelle.Formula = "=Randbetween(1,50000)"
Zelle.Value = Zelle.Value
Next Zelle
End With
Ende = Timer()
Laufzeit = Ende - Start
Debug.Print Laufzeit
End Sub
Dann Ausgeben einer Zusammenfassung in Tabelle1 Spalte B "ArtikelNr2" und Spalte C "Vorkommen"
PHP-Code:
Sub ZusammenfassungErstellung()
Dim cn As Object
Dim rs As Object
Dim strConnection As String
Dim strSQL As String
Dim Start As Single
Dim Ende As Single
Dim Laufzeit As Single
Start = Timer()
Set cn = CreateObject("ADODB.CONNECTION")
strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; DBQ=" & ThisWorkbook.FullName
Set cn = New ADODB.Connection
With cn
.Open strConnection
strSQL = "SELECT ArtikelNr, COUNT(*) FROM [Tabelle1$] GROUP BY ArtikelNr HAVING COUNT(*);"
Set rs = CreateObject("ADODB.RECORDSET")
With rs
.Source = strSQL
.ActiveConnection = strConnection
.Open
Tabelle1.Range("B:C").ClearContents
Tabelle1.Range("B1").Value = "ArtikelNr2"
Tabelle1.Range("C1").Value = "Vorkommen"
Tabelle1.Range("B2").CopyFromRecordset rs
End With
.Close
End With
Set cn = Nothing
Set rs = Nothing
Call DoppelteExtrahieren
Ende = Timer()
Laufzeit = Ende - Start
Debug.Print Laufzeit
End Sub
Dann Ausgabe der doppelten Werte in Tabelle 2 mit Vorkommen
PHP-Code:
Sub DoppelteExtrahieren()
Dim cn As Object
Dim rs As Object
Dim strConnection As String
Dim strSQL As String
Set cn = CreateObject("ADODB.CONNECTION")
strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)}; DBQ=" & ThisWorkbook.FullName
Set cn = New ADODB.Connection
With cn
.Open strConnection
strSQL = "SELECT ArtikelNr2, COUNT(*) FROM [Tabelle1$] GROUP BY ArtikelNr2 HAVING Count(*) > 1;"
Set rs = CreateObject("ADODB.RECORDSET")
With rs
.Source = strSQL
.ActiveConnection = strConnection
.Open
Tabelle2.UsedRange.ClearContents
Tabelle2.Range("A1").Value = "ArtikelNr"
Tabelle2.Range("B1").Value = "Vorkommen"
Tabelle2.Range("A2").CopyFromRecordset rs
End With
.Close
End With
Set cn = Nothing
Set rs = Nothing
End Sub
Gesamtlaufzeit über beide Makros rund 3 Sek.
Sagen wir mal: "Ein gültiger Versuch?"
Gruß
Ich