Soru Mükerer Kayıtları Listelemek

[bulentkars]

Değerli Arkadaşlar Merhaba,

Ekteki tabloda "B:C" Sütunlarında aynı kod ve "KISMI" birden fazla olan olan evrkaları Listelemek veye msgboxta göstermek istiyorum. Örnek dosya ektedir. yardımcı olabilirseniz sevinirim. Şimdiden Teşekkürler

 

[YUSUF44]

Aşağıdaki makro istediğinizi yapıyor:

Sub mukerrerler()
Set s1 = Sheets("ÇEKSENET")
Set s2 = Sheets("Kontrol")
son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
eski = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
s2.Range("A2:B" & eski).ClearContents

Application.ScreenUpdating = False
    Set con = VBA.CreateObject("adodb.Connection")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
    
    sorgu = "select Kodu, count(Türü) as Tur from [ÇEKSENET$] where Türü='KISMI' group by Kodu" ' where Türü is not null"
    Set rs = con.Execute(sorgu)
    
    s2.[A2].CopyFromRecordset rs
    enson = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
    For i = enson To 2 Step -1
        If s2.Cells(i, "B") < 2 Then s2.Rows(i).Delete
    Next
Application.ScreenUpdating = True
s2.Activate
MsgBox "İşlem Tamamlandı", vbInformation
End Sub

SQL kodlarında countif/eğersay kullanımını çözemedim henüz, çözebilirsem muhtemelen daha hızlı bir sonuca ulaşırız.

 

[bulentkars]

Yusuf bey
Çok teşekkür ederim. sadece eğer mükerer kayıt yoksa uyarı versin istiyorum. Kontrol sayfasına sadece mükerer varsa gtisin istiyorum. teşekkürler

 

[YUSUF44]

s2.Activate
MsgBox "İşlem Tamamlandı", vbInformation

Kısmını aşağıdaki kodlarla değiştirip deneyin:

If s2.[B2] = "" Then
    MsgBox "Hiç mükerrer veri yoktur", vbInformation
Else
    s2.Activate
    MsgBox "İşlem Tamamlandı", vbInformation
End If

 

[bulentkars]

Yusuf Bey,

Biraz yavaş çalışıyor kayıt sayısı fazla olduğu için.. yinede Çok çok teşekkür ederim. elinize sağlık.

 

[YUSUF44]

Biraz dolambaçlı yolla daha hızlı bir çözüm buldum sanırım, deneyiniz:

Sub mukerrerler()
Set s1 = Sheets("ÇEKSENET")
Set s2 = Sheets("Kontrol")
son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
eski = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)
s2.Range("A2:B" & eski).ClearContents

Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select Kodu, count(Türü) as Tur from [ÇEKSENET$] where Türü='KISMI' group by Kodu" ' where Türü is not null"
Set rs = con.Execute(sorgu)

s2.[A2].CopyFromRecordset rs
sorgu = "select Kodu, Adet from [Kontrol$] where Adet>=2"
Set rs = con.Execute(sorgu)

enson = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)
s2.Cells(enson + 1, "A").CopyFromRecordset rs
s2.Range("A2:B" & enson).ClearContents

s2.Rows("2:" & enson).Delete
If s2.[B2] = "" Then
    MsgBox "Hiç mükerrer veri yoktur", vbInformation
Else
    s2.Activate
    MsgBox "İşlem Tamamlandı", vbInformation
End If
End Sub

 

[Ömer]

Merhaba,

#2 mesajdaki sorguyu aşağıdaki gibi değiştirip satır silme kodlarını kaldırarak kodu hızlandırabilirsiniz.

sorgu = "select Kodu, count(Türü) as Tur from [ÇEKSENET$] where Türü='KISMI' group by Kodu HAVING COUNT(*) > 1"

 

[bulentkars]

Yusuf Bey,

Süpersiniz allah sizden razı olsun. Çok teşekkürler

 

[YUSUF44]

Merhaba,

#2 mesajdaki sorguyu aşağıdaki gibi değiştirip satır silme kodlarını kaldırarak kodu hızlandırabilirsiniz.

sorgu = "select Kodu, count(Türü) as Tur from [ÇEKSENET$] where Türü='KISMI' group by Kodu HAVING COUNT(*) > 1"

Ömer üstadım teşekkürler, dün hem Türkçe hem de İngilizce olarak araştırmış ama bunu nasıl yapacağımı bulamamıştım.