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

[grummelbaer]

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

[Fennek]

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

[grummelbaer]

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

[Fennek]

Hallo,

mit =zählenwenn() kann man Doppelte (oder auch mehrfache) von eindeutigen unterscheiden.

mfg

[IchBinIch]

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

[RPP63]

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

[IchBinIch]

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

[RPP63]

Hi Du!  :19:
Nö, kein Array, sondern reine Excel-Boardmittel:

1. Spalte C sortieren
   
2. in eine freie Spalte Zeile 1: 1 (als "Überschrift"), ab 2 die Formel: =WENN($A1<>$A2;0;ZEILE())
   
3. Hilfsspalte kopieren und als Wert einfügen
   
4. auf Hilfsspalte Duplikate entfernen anwenden
   
5. 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

[Fennek]

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

[IchBinIch]

...

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