Re: doppelte löschen
06.02.2003 08:26:36
Nepumuk
Hallo Ivan,
dein Programm:Option Explicit
Option Base 1
Option Private Module
Option Compare Text
Dim feld1() As String, feld2() As String, feld3() As String
Public Sub doppelte_loeschen()
Dim zeile As Long, zaehler As Long, geloescht As Long, feld4() As String, leoschstring As String
With Sheets("Tabelle3")
For zeile = 1 To .Range("G65536").End(xlUp).Row
If .Cells(zeile, 7) <> "" Then
zaehler = zaehler + 1
ReDim Preserve feld1(1 To zaehler)
ReDim Preserve feld2(1 To zaehler)
ReDim Preserve feld3(1 To zaehler)
feld1(zaehler) = .Cells(zeile, 7)
feld2(zaehler) = .Cells(zeile, 9)
feld3(zaehler) = zeile
End If
Next
If zaehler > 0 Then
Call sortieren(1, zaehler)
For zeile = zaehler To 2 Step -1
If LCase(feld1(zeile)) = LCase(feld1(zeile - 1)) And LCase(feld2(zeile)) = LCase(feld2(zeile - 1)) Then
geloescht = geloescht + 1
ReDim Preserve feld4(1 To geloescht)
feld4(geloescht) = feld3(zeile - 1)
End If
Next
For zeile = 1 To geloescht
leoschstring = leoschstring & ",G" & feld4(zeile) & ":I" & feld4(zeile)
Next
If geloescht > 0 Then
leoschstring = Mid(leoschstring, 2)
.Range(leoschstring).Delete Shift:=xlUp
End If
End If
End With
End Sub
Private Sub sortieren(Untergrenze As Long, Obergrenze As Long)
Dim index1 As Long, index2 As Long, Element1 As String, Element2 As String
Dim Element3 As String, Zwischenspeicher As Variant
index1 = Untergrenze
index2 = Obergrenze
Zwischenspeicher = feld1(((Untergrenze + Obergrenze) / 2) \ 1) & feld2(((Untergrenze + Obergrenze) / 2) \ 1)
Do
Do While feld1(index1) & feld2(index1) < Zwischenspeicher
index1 = index1 + 1
Loop
Do While Zwischenspeicher < feld1(index2) & feld2(index2)
index2 = index2 - 1
Loop
If index1 <= index2 Then
Element1 = feld1(index1)
Element2 = feld2(index1)
Element3 = feld3(index1)
feld1(index1) = feld1(index2)
feld2(index1) = feld2(index2)
feld3(index1) = feld3(index2)
feld1(index2) = Element1
feld2(index2) = Element2
feld3(index2) = Element3
index1 = index1 + 1
index2 = index2 - 1
End If
Loop Until index1 > index2
If Untergrenze < index2 Then Call sortieren(Untergrenze, index2)
If index1 < Obergrenze Then Call sortieren(index1, Obergrenze)
End Sub
Gruß
Nepumuk