Çoklu düşeyara'da aynı olanlar

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Okulda kütük düzenleme çalışması yapıyoruz. Tabi aynı ad soyada sahip onlarca öğrenci çıkıyor. Liste 12000 kişinin üzerine çıktı fonksiyonla yaptığım işler oldukça ağırlaştı. Yazma işi tamamlandığında 80000 civarında isim olması bekleniyor. Sadece iki sayfa olmasına rağmen isim aramak ciddi süre alıyor.
Saygılarımla

 

[Emir Hüseyin Çoban]

. . .

Tek öğrenci numarasına göre mi arama yapmak istiyorsunuz yoksa
tüm numaralara göre bir rapor mu oluşturulacak.

. . .

 

[Tevfik_Kursun]

Sayın Hüseyin Hocam,
Sadece bu listenin gelmesi yeterli, gerisi numaradan düşeyara ile gelir.
İlginize çok teşekkür ederim
Saygılarımla

 

[Merhum İdris SERDAR]

.

Buradaki örnekleri inceleyin.

http://www.excelgurusu.com/ozet-tablo-ile-suzme/

http://www.excelgurusu.com/formulle-suzme-ornekleri/

.

 

[Emir Hüseyin Çoban]

. . .

Sub KOD()
    
    With Application
        .ScreenUpdating = False: .Calculation = xlCalculationManual: .EnableEvents = False
    End With
    
    Dim SD As Worksheet: Set SD = Sheets("Sayfa1")
    Dim SO As Worksheet: Set SO = Sheets("Sayfa1")
    
    SO.Range("J4:J" & Rows.Count).ClearContents
    ara = SO.Range("I4")
    
    Dim liste(), dizi()
    son = SD.Cells(Rows.Count, "D").End(3).Row
    liste = SD.Range("D4:E" & son).Value
    
    ReDim dizi(1 To son)
    
    For x = 1 To UBound(liste, 1)
        aranan = liste(x, 1)
        If aranan = ara Then
            n = n + 1
            dizi(n) = liste(x, 2)
        End If
    Next x
    
    SO.Range("J4").Resize(son, 1) = Application.Transpose(dizi)
    
    With Application
        .ScreenUpdating = True: .Calculation = xlCalculationAutomatic: .EnableEvents = True
    End With
    
End Sub

. . .

 

[Tevfik_Kursun]

Çok teşekkür ederim Hüseyin Hocam,
size de teşekkür ederim İdris Hocam inceleyeceğim.
saygılarımla

 

[Erdem Akdemir]

Merhaba,

Alternatif olsun.

Sub deneme()
Set con = VBA.CreateObject("adodb.Connection")

con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""


sorgu = "select distinct f2 from[sayfa1$D:E] where f1 = '" & Range("I4") & "' "

Set rs = con.Execute(sorgu)

Range("j4").CopyFromRecordset rs

End Sub

 

[Tevfik_Kursun]

Teşekkür ederim Sayın Kuvari Hocam
Saygılarımla