Mükerrer Verileri, 1 Adet olan Verileri, Boş Verileri listeleme

[baydeniro]

Merhaba arkadaşlar,

E sütununda bulunan verilerin bazıları 1 adetten fazla kere tekrarlıyor, bazıları sadece 1 adet kayıtlı, bazı hücreler ise boş. Bu 3 durumdaki verileri makro yoluyla listelemek mümkün müdür !
Örnek dosya linki : http://s7.dosya.tc/server8/hiaik9/MUKERRER_KAYITLAR_TEK_KAYITLAR.xls.html

 

[turist]

Dosya Linki

İndirip inceleyiniz.

 

[Ömer BARAN]

Merhaba.
Sayın turist mutlaka pratik bir çözüm önermiştir.
Benimki de alternatif olsun.

Sub KRITERLI_SIRALAMA()
sonsat = Cells(Rows.Count, "F").End(3).Row
Range("H7:O" & sonsat).ClearContents
For sat = 7 To sonsat
    If Cells(sat, "E") = "" Then
        Cells(Cells(Rows.Count, "N").End(3).Row + 1, "N") = "E" & sat
        Cells(Cells(Rows.Count, "O").End(3).Row + 1, "O") = Cells(sat, "F")
    ElseIf WorksheetFunction.CountIf(Range("E7:E" & sonsat), Cells(sat, "E")) = 1 Then
        Cells(Cells(Rows.Count, "K").End(3).Row + 1, "K") = Cells(sat, "E")
        Cells(Cells(Rows.Count, "L").End(3).Row + 1, "L") = Cells(sat, "F")
    ElseIf WorksheetFunction.CountIf(Range("H6:H" & sonsat), Cells(sat, "E")) = 0 Then
        Cells(Cells(Rows.Count, "H").End(3).Row + 1, "H") = Cells(sat, "E")
        Cells(Cells(Rows.Count, "I").End(3).Row + 1, "I") = WorksheetFunction.CountIf(Range("E6:E" & sonsat), Cells(sat, "E"))
    End If
Next
End Sub

 

[Ömer BARAN]

İkinci bir alternatif (biçimi dahil listelenecek ise) daha olsun.

Sub KRITERLI_SIRALAMA2()
sonsat = Cells(Rows.Count, "F").End(3).Row
Range("H7:O" & sonsat).ClearContents
For sat = 7 To sonsat
    If Cells(sat, "E") = "" Then
        Range("E" & sat & ":F" & sat).Copy Cells(Cells(Rows.Count, "N").End(3).Row + 1, "N")
        Cells(Cells(Rows.Count, "N").End(3).Row + 1, "N") = "E" & sat
    ElseIf WorksheetFunction.CountIf(Range("E7:E" & sonsat), Cells(sat, "E")) = 1 Then
        Range("E" & sat & ":F" & sat).Copy Cells(Cells(Rows.Count, "K").End(3).Row + 1, "K")
    ElseIf WorksheetFunction.CountIf(Range("H6:H" & sonsat), Cells(sat, "E")) = 0 Then
        Range("E" & sat ).Copy Cells(Cells(Rows.Count, "H").End(3).Row + 1, "H")
        Cells(Cells(Rows.Count, "I").End(3).Row + 1, "I") = _
                        WorksheetFunction.CountIf(Range("E6:E" & sonsat), Cells(sat, "E"))
    End If
Next
End Sub

 

[baydeniro]

sayın üstadım Turist elinize, emeğinize sağlık. çok çok teşekkür ediyorum, sağlıcakla kalın.

 

[baydeniro]

sayın üstadım Ömer Baran harikulade 2 farklı seçenek daha eklemişsiniz. Elinize, emeğinize sağlık. çok çok teşekkür ediyorum, sağlıcakla kalın.