Gruppe
Allgemein
Problem
Wie kann ich alle doppelten Zelleinträge eines Taballenblattes in einen neuen Blatt mit Adressangabe auflisten lassen?
StandardModule: Modul1
Sub ListDoubles()
Dim rng As Range, rngCell As Range
Dim fct As WorksheetFunction
Dim var As Variant
Dim iRow As Integer
Set rng = ActiveSheet.UsedRange
Set fct = WorksheetFunction
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
For Each rngCell In rng.Cells
If fct.CountIf(rng, rngCell.Value) > 1 Then
var = Application.Match(rngCell.Value, Columns(1), 0)
If IsError(var) Then
iRow = iRow + 1
Cells(iRow, 1).Value = rngCell.Value
Else
iRow = var
End If
Cells(iRow, fct.CountA(Rows(iRow)) + 1).Value = _
rngCell.Address(False, False)
End If
Next rngCell
End Sub