Hesap nosunu hızlı şekilde getirme

[mars2]

İyi Günler;

Çalışma sayfasında 45.000 satırlık bir data mevcut, B sutunun da hesap numaraları bulunmaktadır. Herhangi bir hesap numarasını süzdüğümde, C5 hücresine de, süzdüğüm hesap nosu aşağıdaki formülle gelmekte, ancak C5 hücresine süzdüğüm hesap nosu geç gelmektedir. Bunu daha hızlandırmak mümkün müdür. Çünkü bu hesapların tek tek çıktısını aldığımdan zaman kaybı olmaktadır.

İNDİS(B7:B45000;KAÇINCI(1;(ALTTOPLAM(3;KAYDIR(B7:B45000;SATIR(B7:B45000)-SATIR(B7);1)));0))

 

[Korhan Ayhan]

Makro ile hızlandırabilirsiniz.

Link

 

[mars2]

İyi Akşamlar;
Sayın Korhan bey teşekkürler,
Datanın bulunduğuı sayfanın "B" sutununda Hesap noları bulunmaktadır. Filitre ile istediğim hesabı süzmekte bir soruyn bulunmamaktadır.
Süzdüğüm hesap nosunu C5 hücresine de yazdırmak istiyorum.
Örnek uygulama ekte bulunmaktadır. Buna göre; B sutununda 103 nolu hesaba bilgileri süzdüğümde bilgiler gelmektedir. Talebim Bu süzülen hesabın ilk satıtındaki hesap nosu C5 sutununa yazdırmak istiyorumi Yukarıdaki formül ( İNDİS(B7:B45000;KAÇINCI(1;(ALTTOPLAM(3;KAYDIR(B7:B45000;SATIR(B7:B45000)-SATIR(B7);1)));0)) ) bunu yapmakta ancak, hızlı bir şekilde yapmamadığından zaman kaybına neden olmaktadır.
Yukarıda belirtiğim gibi 45.000 satır veri bulunduğundan bir an önce sonuçlandırmak ve dökümünü almak istiyorum.

 

[Korhan Ayhan]

Paylaştığım linkteki örnekleri denediniz mi?

 

[mars2]

Sayın Korhan Ayhan;

Bildirdiğiniz linklerde, sizin tarafından yayınlanan kod aşağıda olup bu uygulamayı çalıştırdığımda, verinin fazla olmas (45.000 satırlık) nedeniye biraz yavaş çalıştığınız düşünmekteyim.

Teşekkürler.

Function SÜZ_KRİTER(Hücre As Range) As String
Dim Filter As String
Filter = ""
On Error GoTo Son
With Hücre.Parent.AutoFilter
If Intersect(Hücre, .Range) Is Nothing Then GoTo Son
With .Filters(Hücre.Column - .Range.Column + 1)
If Not .On Then GoTo Son
Filter = .Criteria1
Select Case .Operator
Case xlAnd
Filter = Filter & " VE " & .Criteria2
Case xlOr
Filter = Filter & " VEYA " & .Criteria2
End Select
End With
End With
Son:
Set WF = WorksheetFunction
SÜZ_KRİTER = Filter
SÜZ_KRİTER = WF.Substitute(SÜZ_KRİTER, "=", "")
SÜZ_KRİTER = WF.Substitute(SÜZ_KRİTER, "<", "")
SÜZ_KRİTER = WF.Substitute(SÜZ_KRİTER, ">", "")
SÜZ_KRİTER = WF.Substitute(SÜZ_KRİTER, "<>", "")
SÜZ_KRİTER = WF.Substitute(SÜZ_KRİTER, "<=", "")
SÜZ_KRİTER = WF.Substitute(SÜZ_KRİTER, ">=", "")
SÜZ_KRİTER = WF.Substitute(SÜZ_KRİTER, "*", "")
Set WF = Nothing
End Function

 

[ÖmerFaruk]

Verdiğiniz örnek dosyada (boş olan) 45.000 satır veri oluşturdum. Süzdüm. Sonuç Başarılı

C5 hücrenize gireceğiniz formül
=SÜZ_KRİTER(B6)

 

[Korhan Ayhan]

Merhaba,

Benim hazırladığım fonksiyon ne kadar sürede sonuç veriyor? Sizin ilk mesajda verdiğiniz fonksiyona göre hız olarak avantaj sağlamadı mı?

Burada amaç çıktı almaksa yöntemi tarif ederseniz farklı alternatifler düşünülebilir.

 

[mars2]

Sayın Korhan Ayhan;

Sorunumu anlatamamış olabilirim.
B7 ila K45000 sutunları arasında veriler bulunmaktadır.

B sutunda (B7:B45000) hesap noları bulunmaktadır. (her hücrede)
6. satırda süzme olayı gerçekleşmekte (Örnekte olduğu gibi) B6 hücresine hesap nosunu yazdığımda istenilen hesap nosa ait veriler süzülmektedir.
C5 hücresine bu seçtiğim hesap nosunun gelmesini istemekteyim. B6 hücresinde seçtiğim hesap nosu (102) C5 hücresine (102) aktarılmasın ve gelen verileri de yazdırmak istiyorum.

Hazırlamış olduğunuz kodla ortalama B6 hücreine yazılan hesap nosu ortalama 45 saniye sonra C5 hücresine aktarılmaktadır. yaklaşık 800 adet hesap olduğunu düşündüğümüz zaman bu süre uzun süre alacağından bu süreyi daha kısı süre aktarmak daha iyi olacağını düşünmekteyim.

Diğer taraftan; farklı çözüm olarak C5 hücresine yazdığımız hesap nosu ile süzmek mümkün müdür. böyle bir durum daha hızlı ve kısa sürede sonuçlanabilir mi?

 

[Korhan Ayhan]

İlk mesajınızda ki formül ne kadar sürede sonuç veriyor?

Ek olarak dosyanızda formüller var mı?
Dosyanızın boyutu ne kadar?

Bu koşullarda işlemin yavaş olmasına etkendir.

 

[mars2]

Sayın Korhan Ayhan;
İNDİS(B7:B45000;KAÇINCI(1;(ALTTOPLAM(3;KAYDIR(B7:B45000;SATIR(B7:B45000)-SATIR(B7);1)));0))
formülle ortalama 50 - 55 saniyede

 

[Korhan Ayhan]

Üstteki mesajımda iki sorum daha vardı. Onlarida cevapladiktan sonra devam edelim.

 

[mars2]

Üstteki mesajımda iki sorum daha vardı. Onlarida cevapladiktan sonra devam edelim.


Ek olarak dosyanızda formüller var mı? evet
sayfanı I4 hücresinde Tutar sutunundan çoketopla formulü ile veri almaktayım.
Dosyanızın boyutu 22,1 mb

 

[Korhan Ayhan]

Anladım..

Dosyanzın boyutu itibariyla zaten yavaş çalışması normal görünüyor.

Senaryo şu şekilde mi;

B sütununda ki benzersiz hesap nolarının tümünü tek tek filtre ettikten sonra sayfayı yazıcıya mı gönderiyorsunuz?

 

[mars2]

Evet

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Hesap_Noya_Gore_Suz_Yazdir()
    Dim S1 As Worksheet, Hesap_No_Listesi As Object, Zaman As Double
    Dim Hesap_No As Variant, WF As WorksheetFunction
    Dim Veri As Variant, Son As Long, X As Long, Say As Long
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    Set Hesap_No_Listesi = VBA.CreateObject("Scripting.Dictionary")
    Set WF = WorksheetFunction
    
    Son = WF.Max(S1.Cells(S1.Rows.Count, 2).End(3).Row, 8)
    
    Veri = S1.Range("B7:B" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Hesap_No_Listesi.Item(Veri(X, 1)) = 1
    Next
    
    For Each Hesap_No In Hesap_No_Listesi.Keys
        S1.Range("B6:K" & S1.Rows.Count).AutoFilter 1, Hesap_No
        S1.Range("C5") = Hesap_No
        S1.PrintOut
    Next
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    Set S1 = Nothing
    Set Hesap_No_Listesi = Nothing
    Set WF = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Veriler yazıcıya gönderilmiştir." & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[mars2]

sayın Korhan Ayhan;

İlgi ve alakanız için teşekkürler.

Kod tek seferde ve ayrı ayrı sayfalar olarak yazıcıdan da çıktı alınabiliyor. Ancak, bu kodu kendi dosyamda uygulamya çalıştığımda benden kaynaklanan hatalar vermektedir. Sizden rica bu uygulamayı örnek dosyaya uygulayarak yayınlamanız mümkün müdür.

 

[Korhan Ayhan]

Ben size tarif edeyim siz kendiniz uyarlarsınız.

Paylaştığınız dosyayı açın.
ALT+F11 tuşlarına basarak kod editörünü açın.
INSERT menüsünden MODULE ekleyin.
Sağ tarafta beyaz bir pencere açılacaktır.
Bu alana önerdiğim kodu yapıştırın.
Excel sayfanıza geri dönün.
Sayfa üzerine uygun bir yere EKLE-ŞEKİL menüsünden bir dikdörtgen ekleyin. Bu şekil makroyu çalıştırmak için kullanılacaktır.
Şekil üzerinde sağ tıklayın.
MAKRO ATA komutunu seçip karşınıza gelen listeden makro adını bir kez tıklayıp işlemi tamamlayın.

Sonra dosyanızı ".xlsm" uzantılı olarak kayıt edin.