Gruß
Stefane
Sub findeDoppelt() Dim rng As Range Dim lRow As Long, lastRow As Long, lCnt As Long Dim wks1 As Worksheet, wks2 As Worksheet, doppel As Worksheet Dim sFirst As String With Application .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False .Calculation = xlCalculationManual End With Set wks1 = Sheets("Tabelle1") Set wks2 = Sheets("Tabelle2") On Error Resume Next Sheets("Doppelt").Delete On Error GoTo 0 Set doppel = Worksheets.Add(after:=wks2) doppel.Name = "Doppelt" lastRow = wks1.Range("A65536").End(xlUp).Row For lRow = 1 To lastRow Set rng = wks2.Range("A:A").Find(wks1.Cells(lRow, 1)) If Not rng Is Nothing Then sFirst = rng.Address Do lCnt = lCnt + 1 doppel.Cells(lCnt, 1) = rng Set rng = wks2.Range("A:A").FindNext(rng) Loop While rng.Address <> sFirst End If Set rng = Nothing Next With Application .ScreenUpdating = True .EnableEvents = True .DisplayAlerts = True .Calculation = xlCalculationAutomatic End With End Sub