Mükerrer silme ile ilgili ?

[Gorarr]

Selamlar burda yapmaya çalıştığım;

Kod ve no uyumu bozulmadan mükerrer olan kayılatların silinmem gerekiyor.
Bu konu ile ilgili bazı kodları denedim ama yapamadım.

Yardımlarınız için şimdiden teşekküler.

 

[İhsan Tank]

Selamlar burda yapmaya çalıştığım;

Kod ve no uyumu bozulmadan mükerrer olan kayılatların silinmem gerekiyor.
Bu konu ile ilgili bazı kodları denedim ama yapamadım.

Yardımlarınız için şimdiden teşekküler.

merhaba
module kodu kopyalayarak deneyiniz

Sub mük_sil()
Dim a As Long
asi = MsgBox("Mükerrer Verileri Sileyim Mi_?", vbYesNo, "Onay")
If asi = vbNo Then Exit Sub
For a = 2 To Cells(65536, "A").End(xlUp).Row
Cells(a, "C") = Range("A" & a) & Range("B" & a)
Next
For sil = [C65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("C2:C" & sil), Range("C" & sil)) > 1 Then Range("A" & sil & ":C" & sil).ClearContents
Next
Range("C2:C65536").ClearContents
Range("A2:B65536").Sort key1:=Range("A2"), ORDER1:=xlAscending
MsgBox "Mükerrer Veriler Silindi", vbInformation, "Bitiş"
End Sub

 

[Gorarr]

İhsan hocam çok teşekkür ederim. Çok güzel çalıştı..

Konuyla ilgili bir şey daha sorsam. Örneğin C,D ,E.. sürunlarınada veriler girmem gerekse. Mükerrer olan satırları komple silecek şekilde kodu modifiye etmek mümkünmü. Teşekkürler..

 

[İhsan Tank]

verileri o şekilde düzenleyip gönderirseniz tam olarak kodu ona göre düzenleyip göndereyim ayrıca mükerrer hangi sütuna göre yapılacak onu da söyleyin yardımcı olamaya çalışayım.

 

[Gorarr]

Hocam #3 nolu mesajıma örnek dosyayı ekledim. Teşekkürler.

 

[İhsan Tank]

Hocam #3 nolu mesajıma örnek dosyayı ekledim. Teşekkürler.

merhaba
kodu

Sub mük_sil()
Dim a As Long
asi = MsgBox("Mükerrer Verileri Sileyim Mi_?", vbYesNo, "Onay")
If asi = vbNo Then Exit Sub
For a = 2 To Cells(65536, "A").End(xlUp).Row
Cells(a, "E") = Range("A" & a) & Range("B" & a)
Next
For sil = [E65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("E2:E" & sil), Range("E" & sil)) > 1 Then _
Range("A" & sil & ":E" & sil).ClearContents
Next
Range("E2:E65536").ClearContents
Range("A2:D65536").Sort key1:=Range("A2"), ORDER1:=xlAscending
MsgBox "Mükerrer Veriler Silindi", vbInformation, "Bitiş"
End Sub

bununla değişin ve deneyin.

 

[Gorarr]

Teşekkür ederim. Saygılar selamlar..

 

[İhsan Tank]

Teşekkür ederim. Saygılar selamlar..

rica ederim
:yazici:

 

[Ömer]

Merhaba,

Dün bende uğraşmıştım, zaman bulamadığım için bitirmek bugüne kaldı.

Alternatif olsun.

Sub BenzersizDuzenle()
 
    Dim d, i As Long, j As Long, deg As String
    Dim dizi() As String, x As Integer
 
    Application.ScreenUpdating = False
 
    Set d = CreateObject("Scripting.Dictionary")
 
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
        deg = Cells(i, "A") & "|" & Cells(i, "B")
        If Not d.exists(deg) Then
            j = j + 1
            ReDim Preserve dizi(1 To 4, 1 To j)
                For x = 1 To 4
                    dizi(x, j) = Cells(i, x)
                Next x
            d.Add deg, Nothing
        End If
    Next i
 
    Range("A2:D" & i).ClearContents
    Range("A2").Resize(j, 4) = Application.WorksheetFunction.Transpose(dizi)
 
    Application.ScreenUpdating = True
 
End Sub

.

 

[Gorarr]

Ömer hocam sizede çok teşekkür ederim. Alternatif olarak kaydettim.