Sub travdem2()
Dim Dl1 As Long, i As Long
Dim Cellule As Range
Dim myRange As Range
With Sheets(ActiveSheet.Name)
Dl1 = .Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
i = 4
Set myRange = .Range("A1:a" & Dl1)
For Each Cellule In .Range("a1:a" & .Cells(Columns(1).Cells.Count, 1).End(xlUp).Row)
Dl1 = Application.WorksheetFunction.CountIf(myRange, Cellule)
If Dl1 <= 3 Then
.Range("N" & i) = Cellule
.Range("N" & i).Offset(0, 1) = Cellule.Offset(0, 1)
i = i + 1
End If
Next Cellule
End With
End Sub