Benzersiz öğeyi saklayıp diğerlerlerini silmek

[gartuns]

Merhaba,
Elimdeki dosyada aynı değerleri taşıyan veriler mevcut, benim amacım bunlardan sadece bir tanesini saklayıp diğerlerini silmek, yardımcı olabilirseniz çok sevinirim.

Şimdiden çok teşekkürler.

 

[uzmanamele]

Merhaba

Veri / filtre / gelişmiş / yalnızca benzersiz kayıtlar
Listeyi, yerinde filtrele değil başka bir yere kopyala tercih edilmelidir.

 

[gartuns]

çok teşekkür ederim, peki bunu kod ile gerçekleştirmek mümkün müdür acaba ?

 

[apocalyt]

kod ile yaptım..eki inceleyin..kolay gelsin..

 

[gartuns]

Merhaba,
Yukarıdaki kodu başka bir dosyaya uyarlamaya çalıştım ama başarılı olamadım, iç içe iki for ile yazmaya çalışsam da sonuca ulaşamadım.

Yapmaya çalıştığım şey, eğer 5ci kolonda uzman1 veya uzman2 yazıyorsa programın 2ci basamağı olarak 1. ve 5. kolondaki veriler eşitse sadece bu satırlardan bir tanesini saklamak istiyorum.

Şimdiden çok teşekürler.

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

Sub MÜKERRER_KAYIT_SİL()
    Dim X As Long, Son As Long
    
    Application.ScreenUpdating = False
    Son = Cells(Rows.Count, 1).End(3).Row
    
    With Range("F2:F" & Son)
        .Formula = "=TRIM(A2&E2)"
        .Value = .Value
    End With
    
    For X = Son To 2 Step -1
        If Trim(Cells(X, 5)) = "Uzman1" Or Trim(Cells(X, 5)) = "Uzman2" Then
            If WorksheetFunction.CountIf(Range("F:F"), Trim(Cells(X, 1) & Cells(X, 5))) > 1 Then
                Rows(X).Delete
            End If
        End If
    Next
    
    Range("F2:F" & Son).ClearContents
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[gartuns]

Çok teşekürkler, yalnız şöyle bir durum var yukarıdaki mesajımda yanlışlıkla 1. ve 4. kolonlar yazacağıma 1.ve 5. kolon yazmışım kusura bakmayın, yardımcı olabilirseniz çok sevinirim, tekrardan kusura bakmayın.

yani 5. kolon uzman1 veya uzman2 ise 1. ve 4. kolonlar da eşitse 1 den fazla olan satırlardan sadece bir tanesini saklamak istiyorum.

 

[gartuns]

kendim düzeltebildim galiba belki birilerinin işine yarar, tekrardan teşekürler

Sub MÜKERRER_KAYIT_SİL()
    Dim X As Long, Son As Long
    
    Application.ScreenUpdating = False
    Son = Cells(Rows.Count, 1).End(3).Row
    
    With Range("F2:F" & Son)
        .Formula = "=TRIM(A2&D2&E2)"
        .Value = .Value
    End With
    
    For X = Son To 2 Step -1
        If Trim(Cells(X, 5)) = "Uzman1" Or Trim(Cells(X, 5)) = "Uzman2" Or Trim(Cells(X, 5)) = "Uzman Onay-**HAVUZ**" Then
            If WorksheetFunction.CountIf(Range("F:F"), Trim(Cells(X, 1) & Cells(X, 4) & Trim(Cells(X, 5)))) > 1 Then
                Rows(X).Delete
            End If
        End If
    Next
    
    Range("F2:F" & Son).ClearContents
    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub