AW: doppelt in Spalte I löschen
20.05.2008 14:08:00
Chris
Servus,
der Code von Daniel its wegen des Zählenwenns in der Formel recht langsam bei großen Datenmengen (Neuberechnung jeder Zelle durch Zählenwenn). Wenn die daten sortiert sind kann man statt mit Zählenwenn nur mit wenn arbeiten, dies ist dann auch sehr schnell, aber für unsortierte Datenreihen ist die Zählenwenn-formel nicht geeignet:
Für unsortierte datenreihen, habe ich mal folgende Codes (schon angepasst für Spalte I) entwickelt:
Option Explicit
Option Base 1
Dim ArrInhalt() As Variant, ArrZeile() As Long, ArrZeileNeu() As Long, ArrInhaltNeu() As Variant
Sub doppelte()
Dim lngletzte As Long, z As Long, x As Long, o As Long, p As Long
'Call Zeit_starten
lngletzte = IIf(IsEmpty(Cells(Rows.Count, 9)), Cells(Rows.Count, 9).End(xlUp).Row, Rows.Count) ' _
letzte beschriebene In Spalte I
ReDim ArrInhalt(1 To lngletzte)
ReDim ArrZeile(1 To lngletzte)
For z = LBound(ArrInhalt()) To UBound(ArrInhalt()) ' Inhalt Spalte I in Array
ArrInhalt(z) = Cells(z, 9)
ArrZeile(z) = Cells(z, 1).Row
Next z
Dim OG&, i&, j&, k&, h, y As Variant ' Inhalt sortieren
OG = UBound(ArrInhalt())
k = OG \ 2
While k > 0
For i = LBound(ArrInhalt()) To OG - k
j = i
While (j >= 0) And (ArrInhalt(j) > ArrInhalt(j + k))
h = ArrInhalt(j)
y = ArrZeile(j)
ArrInhalt(j) = ArrInhalt(j + k)
ArrZeile(j) = ArrZeile(j + k)
ArrInhalt(j + k) = h
ArrZeile(j + k) = y
If j > k Then
j = j - k
Else
j = LBound(ArrInhalt())
End If
Wend
Next i
k = k \ 2
Wend
Dim element1 As Long
For z = UBound(ArrInhalt()) To LBound(ArrInhalt()) + 1 Step -1 ' sortierten Inhalt nach Zeilen _
ordnen
If ArrInhalt(z) = ArrInhalt(z - 1) Then
If ArrZeile(z) 0
For i = LBound(ArrZeile()) To OG - k
j = i
While (j >= 0) And (ArrZeile(j) > ArrZeile(j + k))
h = ArrZeile(j)
y = ArrInhalt(j)
ArrZeile(j) = ArrZeile(j + k)
ArrInhalt(j) = ArrInhalt(j + k)
ArrZeile(j + k) = h
ArrInhalt(j + k) = y
If j > k Then
j = j - k
Else
j = LBound(ArrZeile())
End If
Wend
Next i
k = k \ 2
Wend
x = 1
ReDim ArrZeileNeu(1)
ReDim ArrInhaltNeu(1)
For z = LBound(ArrZeile()) To UBound(ArrZeile()) ' null gesetzte Zeilen aussortieren
If ArrZeile(z) 0 Then
ReDim Preserve ArrZeileNeu(x)
ReDim Preserve ArrInhaltNeu(x)
ArrZeileNeu(x) = ArrZeile(z)
ArrInhaltNeu(x) = ArrInhalt(z)
x = x + 1
End If
Next z
OG = UBound(ArrZeileNeu()) ' zur Sicherheit nochmal neu sortieren
k = OG \ 2
While k > 0
For i = LBound(ArrZeileNeu()) To OG - k
j = i
While (j >= 0) And (ArrZeileNeu(j) > ArrZeileNeu(j + k))
h = ArrZeileNeu(j)
y = ArrInhaltNeu(j)
ArrZeileNeu(j) = ArrZeileNeu(j + k)
ArrInhaltNeu(j) = ArrInhaltNeu(j + k)
ArrZeileNeu(j + k) = h
ArrInhaltNeu(j + k) = y
If j > k Then
j = j - k
Else
j = LBound(ArrZeileNeu())
End If
Wend
Next i
k = k \ 2
Wend
For z = LBound(ArrZeileNeu()) To UBound(ArrZeileNeu()) ' übrige Zeilen nach oben kopieren
Cells(ArrZeileNeu(z), 9).Copy Range("I" & z)
Next z
If lngletzte >= UBound(ArrZeileNeu()) + 1 Then ' überschÜssige Inhalte leeren und Zeilen lö _
schen
Range("I" & UBound(ArrZeileNeu()) + 1 & ":I" & lngletzte).ClearContents
If lngletzte = UBound(ArrZeileNeu()) + 1 Then
Range("I" & lngletzte).EntireRow.Delete
Else
Range("I" & UBound(ArrZeileNeu()) + 1 & ":I" & lngletzte).SpecialCells(xlCellTypeBlanks). _
EntireRow.Delete
End If
End If
'Call Zeit_stoppen
End Sub
Sub schreib()
Dim z As Long, o As Long
For z = LBound(ArrInhaltNeu(), 1) To UBound(ArrInhaltNeu(), 1)
For o = LBound(ArrInhaltNeu(), 2) To UBound(ArrInhaltNeu(), 2)
Cells(z + 8, o) = ArrInhaltNeu(z, o)
Next o
Next z
'Call Zeit_stoppen
End Sub
Gruß
Chris