AW: Mehrfachwerte in Spalte
07.01.2010 18:36:27
Josef
Hallo Dieter,
Code in ein allgemeines Modul kopieren.
Der Code bezieht sich auf das aktive Blatt!
' **********************************************************************
' Modul: Modul5 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub removeDoubleNumbers()
Dim rng As Range, rngMove As Range
Dim lngFirst As Long, lngLast As Long
Dim objSh As Worksheet
Dim vntRet As Variant
lngFirst = 2 'erste zeile mit daten - anpassen!
With ActiveSheet
lngLast = Application.Max(lngFirst, .Cells(.Rows.Count, 4).End(xlUp).Row)
.Columns(5).Insert
.Cells(lngFirst, 5).Formula = "=COUNTIF(" & .Cells(lngFirst, 4).Address & ":" _
& .Cells(lngFirst, 4).Address(0, 0) & "," & .Cells(lngFirst, 4).Address(0, 0) _
& ")"
.Range(.Cells(lngFirst, 5), .Cells(lngLast, 5)).FillDown
For Each rng In .Range(.Cells(lngFirst, 5), .Cells(lngLast, 5))
If rng > 1 Then
If rngMove Is Nothing Then
Set rngMove = rng.EntireRow
Else
Set rngMove = Union(rngMove, rng.EntireRow)
End If
End If
Next
.Columns(5).Delete
End With
If Not rngMove Is Nothing Then
Set objSh = Worksheets.Add(after:=ActiveSheet)
objSh.Name = "Doppelte_" & Format(Now, "dd.MM.yyyy_hhmmss")
rngMove.Copy objSh.Cells(1, 1)
rngMove.Delete
End If
Set rng = Nothing
Set rngMove = Nothing
Set objSh = Nothing
End Sub
Gruß Sepp