Aynı olan verileri ayırma

[krmtr]

1000 satırlık bir excel tablosunda f sütununda bulunan değerlerden alt alta aynı olanların ait oldukları satırı başka bir çalışma sayfasına kopyalamak istiyorum.
Yardımlarınız için teşekkürler.

 

[asi_kral]

Dosya ekler misiniz_?
İçinde açıklama eklerseniz şöyle olsun diye yardımcı olmaya çalışırım

 

[krmtr]

Açıklama yazdım. Umarım anlatabilmişimdir.

 

[krmtr]

access le hallettim ilginiz için teşekkürler...

 

[asi_kral]

Açıklama yazdım. Umarım anlatabilmişimdir.

Merhaba
Bende kodunuzu yazdım. Umarım işinize yarar
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub altalta_aynı_olanları_getir_1967()
'Konu       :   Alt Alta Aynı Olanları Taşı
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Worksheet
Dim a As Long, b As Long, c
Set asi = Sheets("Sayfa1"): Set kral = Sheets("Sayfa2")
Application.ScreenUpdating = False
kral.Select
Range("A1:S" & Rows.Count).ClearContents
c = ActiveCell.Address
For a = 2 To asi.Cells(Rows.Count, "J").End(xlUp).Row
b = kral.Range("A" & Rows.Count).End(xlUp).Row
If b > 1 Then
b = kral.Range("A" & Rows.Count).End(xlUp).Row + 1
End If
If asi.Cells(a - 1, "J") = asi.Cells(a, "J") Then
asi.Range("A" & a - 1 & ":S" & a).Copy
kral.Range("A" & b).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next
Range(c).Select
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

Eki inceleyiniz.