Belirtilen ölçüte göre sayfalardan bulup listeleme

[Ömer]

Merhaba,

Liste sayfasının C1 hücresine girilen Ad Soyadın bütün sayfalardan aranıp listelenmesi, aramaya Toplam sayfası dahil olmaması gerekmektedir. İlgilenen arkadaşlara teşekkür ederim.

.

 

[Kemal Demir]

İyi geceler espiyonajl

umarım doğru anlamısımdır.

 

[Ömer]

İyi geceler espiyonajl

umarım doğru anlamısımdır.

İyi geceler Kemal bey,

Teşekkür ederim istediğim gibi olmuş, yalnız listeleme butonuna 2. kez bastığımda eski bilgilerin devamına listeleme yapıyor, butona bastığımda eski bilgilerin üstüne değilde listeyi silip yeniden düzenlemesi mümkünmüdür, birde veriler arttıkça listeleme hızı oldukça yavaşlıyor listeleme hızını artırabilirmiyiz.

 

[Kemal Demir]

espiyonajl,

Umarım dosya istediğiniz gibi olmusutur.

( Biraz acayip oldu ama yinede istediğiniz çözüme ulasabilirsiniz )

 

[Ömer]

espiyonajl,

Umarım dosya istediğiniz gibi olmusutur.

( Biraz acayip oldu ama yinede istediğiniz çözüme ulasabilirsiniz )

Teşekkür ederim Kemal bey, elinize sağlık..

.

 

[AS3434]

Sayın espiyonajl

Sayın Kemal Bey cevap vermiş ama bende uğraştım boşa gitmesin diye dosyayı ekliyorum. Süre olarak fazla fark etmiyor gibi.

 

[Ömer]

Sayın espiyonajl

Sayın Kemal Bey cevap vermiş ama bende uğraştım boşa gitmesin diye dosyayı ekliyorum. Süre olarak fazla fark etmiyor gibi.

Sizede çok teşekkür ederim Sayın AS3434, elinize sağlık..

.

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak ekteki örnek dosyayı incelermisiniz. Hız açısından size epey zaman kazandıracaktır.

Option Explicit
 
Sub LİSTELE()
    Dim S1 As Worksheet
    Dim Satır As Long
    Dim Sayfa As Worksheet
    Dim Bul As Range, Adres As String
    Set S1 = Sheets("Liste")
 
    Application.ScreenUpdating = False
 
    S1.Select
    [A7:I65536].ClearContents
    If [C1] = Empty Then
        MsgBox "Lütfen isim giriniz !", vbCritical, "Dikkat !"
        [C1].Select
        Exit Sub
    End If
 
    Satır = 7
    For Each Sayfa In Worksheets
        If Sayfa.Name <> "Toplam" And Sayfa.Name <> "Liste" Then
            Set Bul = Sayfa.[C:C].Find([C1])
            If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
            Cells(Satır, 1) = Satır - 6
            Range("B" & Satır & ":H" & Satır).Value = Sayfa.Range("B" & Bul.Row & ":H" & Bul.Row).Value
            Cells(Satır, 9) = Sayfa.Name
            Satır = Satır + 1
            Set Bul = Sayfa.[C:C].FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
            Set Bul = Nothing
        End If
    Next
 
    Set S1 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Kemal Demir]

Korhan Bey,

10 numara olmuş

 

[Ömer]

Selamlar,

Alternatif olarak ekteki örnek dosyayı incelermisiniz. Hız açısından size epey zaman kazandıracaktır.

Merhaba Korhan bey,

Teşekkür ederim. Oldukça hızlı çalışıyor, elinize sağlık..

.

 

[mami68]

Çok güzel bir çalışma olmuş hepinizi kutlarım.

 

[Korhan Ayhan]

Selamlar,

Önermiş olduğum kodun başlangıcına Application.ScreenUpdating = False ve bitişinede Application.ScreenUpdating = True komutlarını eklerseniz daha da hızlı çalışacaktır. Buna göre üstteki kodu ve dosyayı güncelledim.