Mükerrer Kayıt

[askm]

Kolay gelsin.
Sayfa1 de kayıtlar mevcut. Bunların içerisinde B Sutununa göre mükerrer olanlar var. Değerlerden mükerrer olmaksızın tek olarak sayfa 2 ye (mükerrer kayıtta ilk satır alınacak), mükerrer kayıtları da satırları ile Sayfa 3 e kopyalayabilir miyiz. Sayfalara kopyalarken satırı ile kopyalanacak.
Teşekkürler.

 

[askm]

Örnek dosya ektedir.

 

[Orion1]

Dosyanız ektedir.

Sub mukerrer59()
Dim s1 As Worksheet, s2 As Worksheet
Dim sonsat As Long, sat1 As Long, sat2 As Long, i As Long
Sheets("Veri").Select
Set s1 = Sheets("Mükerrerler")
Set s2 = Sheets("Benzersiz")
sonsat = Cells(Rows.Count, "B").End(xlUp).Row
s1.Range("A2:C" & Rows.Count).ClearContents
s2.Range("A2:C" & Rows.Count).ClearContents
Application.ScreenUpdating = False
sat1 = 2: sat2 = 2
For i = 2 To sonsat
    If WorksheetFunction.CountIf(Range("B2:B" & i), Cells(i, "B").Value) = 1 Then
        s1.Cells(sat1, "A").Value = Cells(i, "A").Value
        s1.Cells(sat1, "B").Value = Cells(i, "B").Value
        s1.Cells(sat1, "C").Value = Cells(i, "C").Value
        sat1 = sat1 + 1
    Else
        s2.Cells(sat2, "A").Value = Cells(i, "A").Value
        s2.Cells(sat2, "B").Value = Cells(i, "B").Value
        s2.Cells(sat2, "C").Value = Cells(i, "C").Value
        sat2 = sat2 + 1
    End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamamdır." & vbLf & "evrengizlen@hotmail.com"
End Sub