Birden fazla sütunda mükerrer olan kayıtların silinmesi

[AirJ@rdan]

ekteki dosyada görüldüğü gibi sıra kodu (A SUTUNU) aynı olan satırlara karşılık gelen,B sutunundaki Tezgahlardan aynı olanlardan fazla olan satırları komple silsin.

yanı sırası 10 olan satırlar için bu satırlara karsılık gelen b sutunundaki tezgah kodlarından aynı olanları silinmeli.birer satır kalmalı.

 

[Levent Menteşoğlu]

Aşağıdaki kodu deneyin.

Sub BenzerSil()
son = [A65536].End(3).Row
formul = Replace("SUMPRODUCT((A2:A65536=A999)*(B2:B65536=B999))", 65536, son)
For i = [A65536].End(3).Row To 2 Step -1
If Evaluate(Replace(formul, 999, i)) > 1 Then Rows(i).Delete Shift:=xlUp
Next i
End Sub

 

[AirJ@rdan]

Teşekkür ederim bu tam oldu.peki ekteki şekilde yapmak istesem nasıl bir macro önerirsiniz.

 

[Levent Menteşoğlu]

Aşağıdaki gibi kullanabilirsiniz. Bu sorunuz çok sütunlu mükerrer veri arama işlemi için güzel bir örnek oldu sanıyorum.

Sub BenzerSil()
son = [A65536].End(3).Row
formul = Replace("SUMPRODUCT((A2:A65536=A999)*(B2:B65536=B999)*(C2:C65536=C999))", 65536, son)
For i = [A65536].End(3).Row To 2 Step -1
If Evaluate(Replace(formul, 999, i)) > 1 Then Rows(i).Delete Shift:=xlUp
Next i
End Sub

 

[AirJ@rdan]

Evet çok teşekkür ederim.

 

[zafer]

Merhaba

Aşağıdaki gibi kullanabilirsiniz. Bu sorunuz çok sütunlu mükerrer veri arama işlemi için güzel bir örnek oldu sanıyorum.

Sub BenzerSil()
son = [A65536].End(3).Row
formul = Replace("SUMPRODUCT((A2:A65536=A999)*(B2:B65536=B999)*(C2:C65536=C999))", 65536, son)
For i = [A65536].End(3).Row To 2 Step -1
If Evaluate(Replace(formul, 999, i)) > 1 Then Rows(i).Delete Shift:=xlUp
Next i
End Sub

Sn.Levent harika bir örnek ellerinize sağlık.

 

[Korhan Ayhan]

Selamlar,

Sn. Levent beyi bende tebrik ediyorum. Değişik bir bakışla örnek bir kod hazırlamış. Elinize sağlık.

Ben bu konuda bir düşüncemi belirtmek istiyorum;

Bu önerilen kod az satırlı veri dizisinde fark edilmeyecek kadar hızlı çalışabilir. Tabiki kullanılan bilgisayarın performansıda bu konuda etkili olacaktır. Ben şahsen 50.000 satır üzerinde denedim ve sistem çakıldı kaldı.

Yardımcı sütun kullanılarak ya da farklı yöntem kullanılarak daha hızlı çalışan bir kod tasarlayabilirsek daha etkili olacaktır.

 

[Levent Menteşoğlu]

Sn.Levent harika bir örnek ellerinize sağlık.

Selamlar,

Sn. Levent beyi bende tebrik ediyorum. Değişik bir bakışla örnek bir kod hazırlamış. Elinize sağlık.

Çok teşekkür ederim. Sn Zafer bey, Sn Korhan bey

Aslında bu örnekle ben, VBA ile ilgilenmeye başlamadan önce fonksiyonlar üzerine ciddi çalışmalar yapılmasının önemini işaret etmeye çalışmıştım.

Fonksiyonlar üzerinde geliştirilecek algoritma mantığının, VBA'da oluşturulacak algoritma mantığına ciddi bir temel oluşturacağına her zaman inanırım.

Sonuçta, Excel'de çoğu zaman en pratik çözümlerin, Excelin kendine has fonksiyonlarıyla elde edilebileceğini unutmamak gerekir.

Ben bu konuda bir düşüncemi belirtmek istiyorum;

Bu önerilen kod az satırlı veri dizisinde fark edilmeyecek kadar hızlı çalışabilir. Tabiki kullanılan bilgisayarın performansıda bu konuda etkili olacaktır. Ben şahsen 50.000 satır üzerinde denedim ve sistem çakıldı kaldı.

Yardımcı sütun kullanılarak ya da farklı yöntem kullanılarak daha hızlı çalışan bir kod tasarlayabilirsek daha etkili olacaktır.

Korhan bey, TOPLA.ÇARPIM (SUMPRODUCT) fonksiyonu zaten çok yavaş çalışan bir fonksiyondur. 50.000 adetlik bir listeyi taramaya, bir bu fonksiyonun birde döngünün yavaşlığını katarsanız çok kullanışlı olmayacağı açıktır. Bu konuda size tam olarak katılıyorum.

Benim bu sorudaki önerim ancak sınırlı sayıda satır ve sütun işlemlerinde ciddi bir pratiklik getirebilir. Bunun limitide deneyerek bulunabilir.

Çok sayıda sütunda mükerrer veri aramalarında, şimdilik yardımcı bir sütun kullanılarak oluşturulan çözümler en hızlı çözüm gibi görünüyor. Bunun dışında böyle bir sorunun çözümünde daha hızlı bir yöntem mevcutmudur açıkçası fikrim yok. Ancak her zaman araştırmaya değer bir konu olduğunu düşünüyorum.

 

[Orion1]

. Bunun dışında böyle bir sorunun çözümünde daha hızlı bir yöntem mevcutmudur açıkçası fikrim yok. Ancak her zaman araştırmaya değer bir konu olduğunu düşünüyorum.

ADO ve createobject("ScriptingDictionary") ile dizi kullanrak.50 bin veriyi 7-8 sütunluk bir veriyi 2-3 saniyede alabilirsiniz.
Ben çok yaptım.

 

[Levent Menteşoğlu]

ADO ve createobject("ScriptingDictionary") ile dizi kullanrak.50 bin veriyi 7-8 sütunluk bir veriyi 2-3 saniyede alabilirsiniz.
Ben çok yaptım.

Evren bey, konu listeden sorgulama değil. Çok sütunda mükerrer kayıtların tespiti ve/veya silinmesi. Bu konuda ADO ve Scripting.Dictionary ile bir şey yapılabilirmi hiç araştırmadım.

 

[metinavci23]

Evren Bey Bir örnek ekleyebilirmisiniz?

 

[Orion1]

Merhaba.
Örnek dosya ekledim.
createobject scripting dictionary ile.
asıl önemi olan 50 bin satırda farkedeceksiniz.Hızına inanmayacaksınız.2- 3 saniyede işi bitirecek.
Bunu ekledikten sonra ado ile olanıda yapıcam biraz sonra.
Ado ilede yaptım.Dosayayı günceledim.
Kolay gelsin.

Option Base 1
Sub createObject_Benzersiz()
Dim z As Object, list(), n As Long, myarr(), i As Long
Dim son As Long, deg As String, sat As Long
Application.ScreenUpdating = False
Range("A1").AutoFilter
Range("A1").AutoFilter
Range("I2:K65536").ClearContents
sat = Cells(65536, "A").End(xlUp).Row
If sat < 2 Then
    MsgBox "A sütununda veri yok." & vbLf & "İşlem İptal oldu", vbCritical, "UYARI"
    GoTo son
End If
list = Range("A2:C" & sat).Value
son = UBound(list())
ReDim myarr(1 To 3, 1 To son)
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To son
    deg = list(i, 1) & list(i, 2) & list(i, 3)
    deg = UCase(Replace(Replace(deg, "ı", "I"), "i", "İ"))
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = list(i, 1)
        myarr(2, n) = list(i, 2)
        myarr(3, n) = list(i, 3)
    End If
Next i
Erase list()
Range("I2").Resize(n, 3) = Application.Transpose(myarr)
Range("I2:K" & n - 1).Sort key1:=Range("K2"), key2:=Range("J2"), key3:=Range("I2")
Application.ScreenUpdating = True
Erase myarr()
Set z = Nothing
MsgBox "3 sütundaki Benzersiz veriler createObject Scripting.Dictionary ile çıkarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
son:
Application.ScreenUpdating = True
End Sub

'ADO ile 3 sütun benzersiz veri alma

Sub ADO_SQL_Benzersiz()
Dim conn As ADODB.Connection, rs As ADODB.Recordset, sat As Long
'Reference tools tan microsoft activex data object library 2.x seçiildi
Range("A1").AutoFilter
Range("A1").AutoFilter
Application.ScreenUpdating = False
Range("I2:K65536").ClearContents
sat = Cells(65536, "A").End(xlUp).Row
If sat < 2 Then
    MsgBox "A sütununda veri yok." & vbLf & "İşlem İptal oldu", vbCritical, "UYARI"
    GoTo son
End If
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.FullName & ";extended properties=""excel 8.0;hdr=yes"""
rs.Open "select first(SIRA),first(STOK),first(TEZGAH) from [Sayfa1$A1:C65536] group by SIRA,STOK,TEZGAH order by TEZGAH,STOK,SIRA;", conn, adOpenKeyset, adLockReadOnly
If rs.RecordCount > 0 Then
    Range("I2").CopyFromRecordset rs
    Application.ScreenUpdating = True
    MsgBox "3 sütundaki Benzersiz veriler ADO-SQL ile çıkarıldı." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
son:
Application.ScreenUpdating = True
End Sub

 

[Orion1]

ADO ilede yaptım.
13 numaralı mesajda dosyayı güncelledim.
Kolay gelsin.

 

[hsayar]

rs.Open "select first(SIRA),first(STOK),first(TEZGAH) from [Sayfa1$A1:C65536] group by SIRA,STOK,TEZGAH order by TEZGAH,STOK,SIRA;", conn, adOpenKeyset, adLockReadOnly

ne anlama geliyor

 

[omermahmud]

Evren Bey merhaba,
Hazırladığınız dosyadaki makroyu kullanırken resimdeki gibi hata almaktayım. Ne yapmam gerekiyor?

 

[hsayar]

1 den fazla tekrar edenleri mükerrerler sayfasına, sadece 1 kere terrar edenleri yeni giriş sayfasına aktarmka mümkün mü? addob ile

 

[okurt7]

Levent bey yazdığınız kodlar için çok teşekkür ederim. Benim de işime yarayacak.