Doppelte Zellen löschen mit Dictionary
16.02.2013 07:45:49
Erich
Hi Tom,
probier mal
Option Explicit
Sub start()
Dim ii As Long
For ii = 1 To 5 ' Spalten 1 bis 5 außer 3 (A,B,D,E)
If ii 3 Then SpalteOhneDups_Dictionary ii
Next ii
End Sub
Sub SpalteOhneDups_Dictionary(lngSp As Long)
Dim objDic As Object, lngAnz As Long, arrW, zz As Long, rngDel As Range
Set objDic = CreateObject("Scripting.Dictionary")
lngAnz = Cells(Rows.Count, lngSp).End(xlUp).Row
arrW = Cells(1, lngSp).Resize(lngAnz).Value ' Werte der Spalte in Array
If lngAnz > 1 Then
For zz = 1 To lngAnz
If Not IsEmpty(arrW(zz, 1)) Then
If objDic.Exists(arrW(zz, 1)) Then ' merken, wenn schon da
If rngDel Is Nothing Then
Set rngDel = Cells(zz, lngSp)
Else
Set rngDel = Union(rngDel, Cells(zz, lngSp))
End If
Else
objDic(arrW(zz, 1)) = 0 ' eintragen
End If
End If
Next zz
End If
If Not rngDel Is Nothing Then rngDel.Delete xlShiftUp ' löschen
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich