Çözüldü Şartlı Benzersiz Liste oluşturma.

[TUNCA ERSİN]

Sy. Hocalarım ;

Yirmi bin satırdan oluşan ve devam edecek olan raporlama çalışmam da benzersiz ve şartlı iki tarih arasın da benzersiz verileri listelemem gerekmektedir. Yardımınızı rica ederim. Teşekkür ederim.

 

[N.Ziya Hiçdurmaz]

Merhaba; aşağıdaki kodu deneyiniz.

Sub test()
Dim s As Integer
Dim sat As Integer
s = 2
v = Sayfa2.Range("aa1:aa" & Sayfa2.Cells(Rows.Count, "aa").End(xlUp).Row)
For sat = 2 To UBound(v)
If WorksheetFunction.CountIf(Sayfa2.Range("aa2:aa" & sat), v(sat, 1)) = 1 Then
Sayfa1.Cells(s, "a") = v(sat, 1)
s = s + 1
End If
Next
s = 2
v = Sayfa2.Range("b1:aa" & Sayfa2.Cells(Rows.Count, "b").End(xlUp).Row)
For sat = 2 To UBound(v)
If v(sat, 1) >= Sayfa1.[j1] And v(sat, 1) <= Sayfa1.[j2] And Sayfa1.[k1] = v(sat, 26) Then
If WorksheetFunction.CountIf(Sayfa2.Range("z2:z" & sat), Sayfa2.Cells(sat, "z")) = 1 Then
Sayfa1.Cells(s, "k") = v(sat, 25)
s = s + 1
End If
End If
Next
End Sub

 

[Korhan Ayhan]

Alternatif;

Hız olarak biraz daha avantajlı sonuç verecektir.

Option Explicit

Sub Conditional_Unique_List()
    Dim S1 As Worksheet, My_Connection As Object, My_Recordset As Object, My_Query As String
 
    Application.ScreenUpdating = False
 
    Set My_Connection = CreateObject("AdoDB.Connection")
    Set My_Recordset = CreateObject("AdoDB.Recordset")
    Set S1 = Sheets("Sayfa1")
 
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=Yes"""
 
    My_Query = "Select Distinct [Liste] From [Veri$] " & _
               "Where [Tarih] Between " & CLng(CDate(S1.Range("J1"))) & " And " & CLng(CDate(S1.Range("J1")))
 
    My_Recordset.Open My_Query, My_Connection, 1, 1
 
    S1.Range("A2:A" & S1.Rows.Count).ClearContents
    S1.Range("A2").CopyFromRecordset My_Recordset
    My_Recordset.Close
 
    My_Query = "Select Distinct [Alıcı] From [Veri$] " & _
               "Where [Tarih] Between " & CLng(CDate(S1.Range("J1"))) & " And " & CLng(CDate(S1.Range("J1"))) & " And [Liste] = '" & S1.Range("K1") & "'"
 
    My_Recordset.Open My_Query, My_Connection, 1, 1
 
    S1.Range("K2:K" & S1.Rows.Count).ClearContents
    S1.Range("K2").CopyFromRecordset My_Recordset
 
    Columns.AutoFit
  
    My_Recordset.Close
    My_Connection.Close
   
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
    Set S1 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[TUNCA ERSİN]

Sy. @Korhan Ayhan ;

Hocam bu şekilde hata verdi.

 

[TUNCA ERSİN]

Sy. @N.Ziya Hiçdurmaz ;
Hocam bu şekilde hata verdi.

 

[N.Ziya Hiçdurmaz]

Merhaba; eklediğiniz dosyadaki sayfa isimleri ile hata aldığınız dosyadaki isimler eşleşmiyor.
kodlardaki sayfa1'i sayfa2, sayfa2'yi sayfa4 olarak değiştirip deneyiniz

 

[Korhan Ayhan]

Merhaba,

Kodları deneyerek paylaştım. Hata veren dosyanızı paylaşırsanız deneyebilirim.

 

[TUNCA ERSİN]

Sy. @Korhan Ayhan ve Sy. @N.Ziya Hiçdurmaz ;

Hocalarım elinize ve emeğinize sağlık Allah razı olsun teşekkür ederim.
@N.Ziya Hiçdurmaz ;
hocamın dediğini yapınca çalışma yapıldı gayet güzel çalışıyor. tek bir sorun var oda yavaş çalışıyor. Teşekkür ederim.

 

[Korhan Ayhan]

Benim önerim hız olarak nasıl sonuç verdi?