sutüna göre, satırlardan birer tane kalsın

[excellkurdu]

Merhaba Arkadaşlar,
B Sütunundaki aynı değerlerden (metin, tarih ya da sayı olabilir) birer tanesi kalacak şekilde fazlalık (B sutunundaki aynı değerler) ları nasıl silebiliriz?
Yani B sutununa bak, aynı değerleri bul, B sutununa göre aynı olanların bulunduğu tüm satırları sil, fazlalık olanlardan birer tane kalsın. Bunu yapabilecek makroya ihtiyacım var.
örnek Çaklışmam ektedir. İçindeki kod örnektir.
Şimdiden teşekkür ederim.

 

[Ziynettin]

Merhaba, aşağıdaki kodu denermisiniz.

Sub excellkurdu()
Dim i As Integer, j As Integer, son As Integer
    son = Range("A" & Rows.Count).End(3).Row
    For i = 1 To Sheets.Count
        For j = 6 To son
            If WorksheetFunction.CountIf(Sheets(i).Range("B6:B" & j), Sheets(i).Cells(j, 2)) > 1 Then
            Sheets(i).Range(Sheets(i).Cells(j, 1), Sheets(i).Cells(j, 6)).Delete shift:=xlUp
            End If
        Next j
    Next i
MsgBox "İşlem tamam.", vbInformation
End Sub

 

[excellkurdu]

Hocam ellerinize sağlık. Çalışdı fakat 2 ricam daha var. yyy sayfasındaki 6. ve 10. satırlardaki "Ali" olan satırlar aynen kaldı, bunları silmedi.
Birde tüm sayfalarda çalışıyor. FORM diye bir sayfam olsa bu sayfada değilde sadece xxx, yyy, zzz sayfalarında çalışması için ne yapabiliriz? Teşekkür ederim.

 

[muygun]

Merhaba;
Alternatif olsun.
İyi çalışmalar.

 

[Ziynettin]

Hocam ellerinize sağlık. Çalışdı fakat 2 ricam daha var. yyy sayfasındaki 6. ve 10. satırlardaki "Ali" olan satırlar aynen kaldı, bunları silmedi.
Birde tüm sayfalarda çalışıyor. FORM diye bir sayfam olsa bu sayfada değilde sadece xxx, yyy, zzz sayfalarında çalışması için ne yapabiliriz? Teşekkür ederim.

dosyanız ektedir.

 

[excellkurdu]

Her iki hocam, ellerinize ve aklınıza sağlık. Çok güzel çalışmalar olmuş. Her iki çalışmayıda kendime uyarlamaya çalışıyorum. Allah sizlerden razı olsun.

 

[excellkurdu]

Hocalarım Tasmed ve uygun dan aldığım ve son olarak Kendime Uyarladığım kod. Farklı sayfalardan kodu çalıştırma. belki lazım olan olur.

Sub mukerrer_sil()
Sheets("Dataservis").Visible = xlSheetVisible
Sheets("Dataservis").Select
If MsgBox("Mükerrer kayıtları silmek istediğinizden emin misiniz ?", vbCritical + vbYesNo, " UYARI") = vbYes Then
sayfaadı = ActiveSheet.Name
For Z = 6 To Sheets(sayfaadı).Cells(65536, "c").End(xlUp).Row
If WorksheetFunction.CountIf(Sheets(sayfaadı).range("c6:c" & Z), Sheets(sayfaadı).Cells(Z, "c")) > 1 Then
Sheets(sayfaadı).Cells(Z, "SSS") = "sil"
End If
Next
For Z = 1000 To 6 Step -1
If Cells(Z, "SSS") = "sil" Then
Rows(Z).Delete shift:=xlUp
End If
Next Z
    Else
    'MsgBox "Silme İşleminden Vazgeçdiniz "
    'Sheets("Dataservis").Visible = xlVeryHidden
    Sheets("ServisFORMU").Select
End If
'Sheets("Dataservis").Visible = xlVeryHidden
Sheets("ServisFORMU").Select
End Sub