Herbers CD 045799

Sub ListDoubles2()
' Herbers 045799
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