süzülü ekstrede bakiye bulma

[y.selim]

ayrıntıları dosyada açıkladım
ilgilinenlere çok teşekkür ederim

 

[Ömer BARAN]

Merhaba.
Süzme işlemini sadece isim sütununda yapacaksanız, E2 hücresine;

=ETOPLA($B$2:B2;B2;$C$2:C2)-ETOPLA($B$2:B2;B2;$D$2:D2)

formülünü uygulayıp aşağğı doğru kopyalayınız.

 

[y.selim]

tamamdır ömer bey çok teşekkür ederim.

 

[Ömer BARAN]

tamamdır ömer bey çok teşekkür ederim.

EStağfurullah, iyi günler dilerim.

 

[y.selim]

ömer bey ekstrede yaklaşık 16000 satır olduğu için bu formül ağır geldi hesaplama yapması çok uzun sürüyor.bu sorunu nasıl çözebiliriz?

 

[Erdem Akdemir]

Merhaba,

E3 hücresine kopyalayabilirsiniz.

Daha hızlı çalışacaktır. Yine olmazsa makrolu çözüm gerekir.

=ALTTOPLAM(9;$C$2:C3)-ALTTOPLAM(9;$D$2:D3)

 

[y.selim]

çok sağolun sayın kuvari bu şekilde yeterince hızlı çalışıyor.

 

[y.selim]

merhabalar
yukarıdaki soruya syn kuvarinin yazdığı formül çare olmaktadır fakat 16000 e yakın satır olduğu için dosya açılırken çok bekletiyor bunu nasıl giderebiliriz?
syn kuvari makro ile çözülebilir demişti.ilgilenen herkese çok teşekkür ederim.

 

[Erdem Akdemir]

Merhaba,

Böyle bir çalışmayı makro ile de yapsanız zaman alacaktır. Girdiğiniz her veri için kodun baştan çalışması gerekir.

Veri girişi yapılırken rapor alacağınıza veri girişi bittikten sonra özet tablo tam sizin istediğiniz işlemi yapacaktır.Özet tablo işlemini araştırın.

 

[y.selim]

özet tabloyu denedim hocam.çok kullanışlı bir özellik olmasına rağmen bu mevzuda işimi görmüyor.ben makro ile pratik çözümü varmıdır diye merak ettim. yoksa eski usul kullanmaya devam edeceğiz.teşekkür ederim ilginiz için.

 

[Korhan Ayhan]

Normalde istediğiniz çözüm yolu exceli her zaman yoracaktır.

İsim sütunundan tek isim filtrelediğinizi varsayarak aşağıdaki kodu öneriyorum.

Çoklu isim filtreleyecekseniz kodu revize etmek gerekecektir.

Kodu 18.000 satırda denediğimde yaklaşık 5-6 saniyede sonuç üretiyor.

Option Explicit

Sub BAKIYE_GUNCELLE()
    Dim X As Integer, Say As Integer, Kriter As Variant
    Dim Alan As Range, Veri As Range, Son As Long
    Dim Bakiye As Double, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    If ActiveSheet.AutoFilterMode Then
        For X = 1 To ActiveSheet.AutoFilter.Filters.Count
            If ActiveSheet.AutoFilter.Filters.Item(X).On Then Say = Say + 1
        Next
                
        If Say > 0 Then
            Kriter = Evaluate("=INDEX(B2:B1048576,MATCH(1,SUBTOTAL(3,OFFSET(B2:B1048576,ROW(B2:B1048576)-ROW(B2),,1)),0))")
            On Error Resume Next
            ActiveSheet.ShowAllData
            On Error GoTo 0
        End If
    End If
    
    Son = Cells(Rows.Count, 1).End(3).Row
    Range("E2:F" & Rows.Count).ClearContents
    If Kriter <> Empty Then Range("A1:F" & Rows.Count).AutoFilter 2, Kriter
    
    Set Alan = Range("A1:A" & Son).SpecialCells(xlCellTypeVisible)
    
    If Not Alan Is Nothing Then
        For Each Veri In Alan
            If Cells(Veri.Row, "B") <> "" Then
                If IsNumeric(Cells(Veri.Row, "C")) Or IsNumeric(Cells(Veri.Row, "D")) Then
                    Cells(Veri.Row, "E") = Bakiye + (Cells(Veri.Row, "C") - Cells(Veri.Row, "D"))
                    Bakiye = Cells(Veri.Row, "E")
                    If Cells(Veri.Row, "E") = 0 Then
                        Cells(Veri.Row, "F") = Empty
                    ElseIf Cells(Veri.Row, "E") > 0 Then
                        Cells(Veri.Row, "F") = "BORÇLU"
                    Else
                        Cells(Veri.Row, "F") = "ALACAKLI"
                    End If
                End If
            End If
        Next
    End If

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "İşlem süresi; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[y.selim]

Korhan Hocam ilgilendiğiniz için müteşekkirim.
Lakin,kendi koyduğum örnek dosyayı indiremediğim için kodu tam anlayamadım .Asıl dosya ile örnek dosya biraz farklıydı.
Bugün altın üyeliğimi aktif edip en kısa sürede size geri dönüş yapacağım.İyi çalışmalar.

 

[Erdem Akdemir]

Örnek bir dosya eklediğinizde size daha kolay ve kullanışlı bir yöntem önerebilirim.

Raporu veri girilen ekranda almanıza gerek yok, yada öyle bir hesaplamanın orda yapılmasına.

 

[y.selim]

bilgisayardan uzun süreli olarak uzak kaldığım için geri dönüşü geç yaptım bunun için özür dilerim.
Korhan Hocam sanırım yazdığınız kodlar işimizi tam olarak görüyor.fakat makro bilgim az olduğu için bayadır uğraşmama rağmen ben kodları orjinal kitaba uyarlayamadım.bu yüzden kitabın aslını ekliyorum.kodları düzenleyebilirseniz çok makbule geçer.ilginiz için teşekkür eder, iyi çalışmalar dilerim.

 

[Erdem Akdemir]

Merhaba,

Size bir tavsiye vermek isterim. Veri girdiğiniz alanda rapor almayın. Rapor için yeni bir sayfa oluşturabilirsiniz. Birde verileri başka çalışma kitabından formülle aldığınızı söylemişsiniz, onlarda kodla getirilebilir.

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Option Explicit

Sub FILTRELE()
    Dim X As Integer, Say As Integer, Kriter As Variant
    Dim Alan As Range, Veri As Range, Son As Long
    Dim Bakiye As Double, Zaman As Double
    
    Kriter = Application.InputBox("Filtrelemek istediğiniz ismi giriniz.", "KRİTER GİRİŞİ")
    If Kriter = "" Or Kriter = False Then Exit Sub
    Kriter = "*" & Kriter & "*"
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    If ActiveSheet.AutoFilterMode Then Range("A1").AutoFilter
    Son = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A1:J" & Son).AutoFilter 6, Kriter
    Range("B2:J" & Son).Sort Range("B2"), xlAscending
    ActiveSheet.Calculate
    
    If ActiveSheet.AutoFilterMode Then
        For X = 1 To ActiveSheet.AutoFilter.Filters.Count
            If ActiveSheet.AutoFilter.Filters.Item(X).On Then Say = Say + 1
        Next
                
        If Say > 0 Then
            Kriter = Evaluate("=INDEX(F2:F1048576,MATCH(1,SUBTOTAL(3,OFFSET(F2:F1048576,ROW(F2:F1048576)-ROW(F2),,1)),0))")
            On Error Resume Next
            ActiveSheet.ShowAllData
            On Error GoTo 0
        End If
    End If
    
    Son = Cells(Rows.Count, 1).End(3).Row
    Range("I2:J" & Rows.Count).ClearContents
    If Not IsError(Kriter) Then
        If Kriter <> Empty Then Range("A1:J" & Rows.Count).AutoFilter 6, Kriter
    End If
    
    Set Alan = Range("A1:A" & Son).SpecialCells(xlCellTypeVisible)
    
    If Not Alan Is Nothing Then
        For Each Veri In Alan
            If Cells(Veri.Row, "F") <> "" Then
                If IsNumeric(Cells(Veri.Row, "G")) Or IsNumeric(Cells(Veri.Row, "H")) Then
                    Cells(Veri.Row, "I") = Bakiye + (Cells(Veri.Row, "G") - Cells(Veri.Row, "H"))
                    Bakiye = Cells(Veri.Row, "I")
                    If Cells(Veri.Row, "I") = 0 Then
                        Cells(Veri.Row, "J") = Empty
                    ElseIf Cells(Veri.Row, "I") > 0 Then
                        Cells(Veri.Row, "J") = "BORÇLU"
                    Else
                        Cells(Veri.Row, "J") = "ALACAKLI"
                    End If
                End If
            End If
        Next
    End If

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[y.selim]

Korhan Hocam, kodunuzu denedim teşekkür ederim.
burda iki farklı kod çıkıyor.süzme makrosu çalışıyor, fakat diğer kod "Run-time error '1004'-hiçbir hücre bulunamadı" hatasını veriyor.birde iki kodu birleştirebilirsek daha pratik bir kullanım sağlar diye düşünüyorum.ara butonuna basıp ismi yazdığımızda hem sıralasa hem de bakiyeleri yazsa.

 

[Korhan Ayhan]

Tek kod haline getirdim. Üstteki mesajımda ki kodu revize ettim. Deneyiniz.

 

[y.selim]

Üstadım harcadığınız emek için çok teşekkürler.Yazdığınız kodlar çok makbule geçti.Kodlar yeterince hızlı çalışıyor, işlem yapması ortalama 0,80 saniye sürüyor.
Sayın Kuvari'ye de verdiği öneriler için teşekkür ederim.Bu şekilde şimdilik benim işimi görüyor.