• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Filtrelenmiş satırlarda yürüyen bakiye

  • Konbuyu başlatan Konbuyu başlatan turanb
  • Başlangıç tarihi Başlangıç tarihi
T

turanb

Katılım
18 Mart 2012
Mesajlar
440
Excel Vers. ve Dili
2013
Merhaba,

Sayfada sadece filtrelediğim firma için yürüyen bakiye almasını istiyorum. Ancak aşağıdaki kodda bütün satırlar için hesaplıyor ve filtre yaptığımda sadece filtrelediğim firma için hesaplamıyor. Filtreleme yapmış olsamda gizlenmiş satıraları da hesaplıyor ve filtre yaptığım firmanın bütün satırlar içindeki bakiye sütununa denk gelen rakamları yazıyor.

Mesela Alttoplam gibi sadece filtrelenen kayıtlar için yürüyen bakiye gerekiyor. Yardımcı olabilir misiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)


On Error Resume Next
If Intersect(Target, Range("a2")) Is Nothing Then Exit Sub
    METİN1 = Range("a2")
    Set FC5 = Range("A3:g10000").Find(What:=METİN1)
    Application.Goto Reference:=Range(FC5.Address), _
       Scroll:=False
    Selection.AutoFilter Field:=1, Criteria1:="*" & METİN1 & "*"
    If METİN1 = "" Then
    Selection.AutoFilter Field:=1
  
    End If
    
    
   ' If Intersect(Target, Range("a2")) Is Nothing Then Exit Sub
   ' If Cells(Target.Row, "C") = "" Then
   ' Cells(Target.Row, "C") = Format(Now, "dd.mm.yyyy")
   ' End If

If Intersect(Target, Range("a2")) Is Nothing Then Exit Sub
  Range("g4:g65536").ClearContents
Range("G4") = Range("E4") - Range("F4")
For i = 5 To [A65536].End(3).Row
Cells(i, "G") = Cells(i - 1, "G") + Cells(i, "E") - Cells(i, "F")
Next i

End Sub
 
Döngü bölümüne satır yüksekliğini kontrol eden koşulu eklerseniz sanırım istediğiniz sonuca ulaşabilirsiniz.

Kod: 
For i = 5 To [A65536].End(3).Row
    If Cells(i, "A").RowHeight = 0 Then Cells(i, "G") = Cells(i - 1, "G") + Cells(i, "E") - Cells(i, "F")
Next i
 
Korhan Ayhan' Alıntı:
Döngü bölümüne satır yüksekliğini kontrol eden koşulu eklerseniz sanırım istediğiniz sonuca ulaşabilirsiniz.

Kod: 
For i = 5 To [A65536].End(3).Row
    If Cells(i, "A").RowHeight = 0 Then Cells(i, "G") = Cells(i - 1, "G") + Cells(i, "E") - Cells(i, "F")
Next i
Genişletmek için tıkla ...

Teşekkürler Korhan bey ilginize.

Ben ilk satır hariç diğer kümültaif kısmını çalıştırmıştım. Ancak ilk satırdaki işlem farklı. Onu çalıştıramadım.

şöyleki;

ilk satır Cells(i,"G") = Cells(i,"E") - Cells(i,"F")

sonraki satırlar Cells(i,"G") = Cells(i-1,"G") + Cells(i,"E") - Cells(i,"F")

Gibi işlem lazım. ancak püf nokta filtrelenmiş satırlarda yapması gerekiyor bu işlemi.


Sizin yaptığınız anladığım kadarıyla filtrelenmiş ilk satırı işaret ediyor. Ama aşağıdaki gibi uyguladım ilk satır için sonuç alamadım.

Kod: 
If Intersect(Target, Range("a2")) Is Nothing Then Exit Sub
     Range("g4:g65536").ClearContents
     
   For i = 4 To Cells(65536, "A").End(3).Row 'xlUp

    If Cells(i, "A").RowHeight = 0 Then Cells(i, "G") = Cells(i, "E") - Cells(i, "F")
 
  Next i
 
Sayın üstadlar konu ilgi çekici değil galiba.

Ama benim bu çözüme ihtiyacım var. Sizin için basit birşey olsa gerek.
 
Merhaba.

Sorunuzu, cevabımın altındaki İMZA bölümünde yer alan açıklamalarda belirttiğim şekilde,
örnek belge ile desteklemenizi öneriyorum.

Böylece daha hızlı ve net çözüme ulaşabileceğiniz düşünüyorum.

Örnek belge olmadan verilecek cevap hayali olacak ama,
For-Next döngüsü yerine aşağıdaki şekilde istediğiniz sonucun alınması lazım gibi geldi bana.
.
Kod: 
[FONT="Arial Narrow"]    With Range("G5:G" & [A65536].End(3).Row)
        .Formula = "=SUMIF($A$4:A5,$A5,$E$4:E5)-SUMIF($A$4:A5,$A5,$F$4:F5)"
        .Value = .Value
    End With[/FONT]
 
Konuya tam hakim değilim ancak Korhan Bey'in önerdiği kod satır yüksekliği 0 ise işlem yaptırıyor, sanıyorum siz 0'dan büyükse işlem yapmasını istiyorsunuz. Bu durumda

If Cells(i, "A").RowHeight > 0 Then Cells(i, "G") = Cells(i - 1, "G") + Cells(i, "E") - Cells(i, "F")

Olması gerekmez mi?
 
Ömer BARAN' Alıntı:
Merhaba.

Sorunuzu, cevabımın altındaki İMZA bölümünde yer alan açıklamalarda belirttiğim şekilde,
örnek belge ile desteklemenizi öneriyorum.

Böylece daha hızlı ve net çözüme ulaşabileceğiniz düşünüyorum.

Örnek belge olmadan verilecek cevap hayali olacak ama,
For-Next döngüsü yerine aşağıdaki şekilde istediğiniz sonucun alınması lazım gibi geldi bana.
.
Kod: 
[FONT="Arial Narrow"]    With Range("G5:G" & [A65536].End(3).Row)
        .Formula = "=SUMIF($A$4:A5,$A5,$E$4:E5)-SUMIF($A$4:A5,$A5,$F$4:F5)"
        .Value = .Value
    End With[/FONT]
Genişletmek için tıkla ...

Hocam dosya linki aşağıdadır.

http://s9.dosya.tc/server/auh34t/ORNEK_.rar.html
 
Evet sehven "=" yazmışım.

Yusuf bey düzeltmeniz için teşekkür ederim.
 
For-next döngüsü veri yığının büyüklüğüne göre zaman alabilir sanırım.

Benim gönderdiğim cevaptaki satır numaralırının tümünü 1'er azaltarak çalıştırır mısınız?
.
 
Alternatif;

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    If Range("A2").Value = "" Then
        ActiveSheet.ShowAllData
        Cells(4, "G") = Cells(4, "E") - Cells(4, "F")
        Son = Cells(Rows.Count, 1).End(3).Row
        With Range("G5:G" & Son)
            .Formula = "=G4+E5-F5"
            .Value = .Value
        End With
    Else
        Range("G4:G" & Rows.Count).ClearContents
        Range("A3:G" & Rows.Count).AutoFilter 1, Range("A2").Value
    
        Bakiye = 0
        Son = Cells(Rows.Count, 1).End(3).Row
    
        For X = 4 To Son
            If Rows(X).RowHeight > 0 Then
                If Cells(X, "A").Value = Range("A2").Value Then
                    Cells(X, "G") = Bakiye + Cells(X, "E") - Cells(X, "F")
                    Bakiye = Cells(X, "G")
                End If
            End If
        Next
    End If
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub
 
Ek olarak aşağıdaki kod daha hızlı sonuç verecektir.

Kod: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, Son As Long, Satir As Long
    Dim Veri(), Kriter As Variant, Bakiye As Double, X As Long
    
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    Set S1 = Sheets("Sayfa1")
    S1.ShowAllData
    
    If Range("A2").Value = "" Then
        Cells(4, "G") = Cells(4, "E") - Cells(4, "F")
        Son = Cells(Rows.Count, 1).End(3).Row
        With Range("G5:G" & Son)
            .Formula = "=G4+E5-F5"
            .Value = .Value
        End With
    Else
    
        Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row
        S1.Range("G4:G" & Satir).ClearContents
        Veri = S1.Range("A4:F" & Satir).Value
        Kriter = S1.Range("A2").Value
        Bakiye = 0
        
        ReDim Dizim(1 To UBound(Veri, 1), 1 To 6)
        
        For X = 1 To UBound(Veri, 1)
            ReDim Preserve Dizim(1 To UBound(Veri, 1), 1 To 6)
            If Veri(X, 1) = Kriter Then
                Dizim(X, 1) = Bakiye + Veri(X, 5) - Veri(X, 6)
                Bakiye = Dizim(X, 1)
            End If
        Next
        
        S1.Range("G4:G" & UBound(Dizim) + 3) = Dizim
        Range("A3:G" & Rows.Count).AutoFilter 1, Range("A2").Value
    End If
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
End Sub
 
Sayın Ömer BARAN ve Korhan Ayhan üstadlarım desteğiniz için teşekkür ederim.

Ömer BARAN sizin kodlarınız da çalışıyor ancak benim sistemle alakalı bir özellikten dolayı çalıştırmakta zorlanıyorum.
Sebebi bende Navigator (LOGO) ile çalışan ve birçok sayfalardan oluşan aynı zamanda bu sayfalarda birçok Navigator formulu bulunan bir çalışma kitabı var.
Otomatik hesaplama özelliği açılınca bütün sayfalardaki formulleri hesaplamaya başlıyor. O yüzden çalıştırırken sıkıntı çıkyor.

Ömer BARAN şimdi tekrar baktım kodlarınızdaki otomatik hesaplama satırını devre dışı bıraktım. Sizinki de sorunsuz çalışıyor. Cevap bulamazken şimdi 4 farklı kod seçeneği var. Hangisini kullansam bilemedim. :)

Korhan Ayhan bey sizin gönderdiğiniz kodlardan ilkinde sorun yok güzel çalışıyor. Ama ikincisinde yine otomatik hesapla aktif edildiği için sıkıntı oluyor. Otomatik hesaplamayı kodlardan ' ile devre dışı bıraktığım zaman yine bu kodlarda sorunsuz çalışıyor ama sanki ilk gönderdiğiniz kod sanki daha hızlı. dolayısıyla ben bunu kullanacağım.

Birde alternatif olsun diye başka bir dost siteden bir arkadaşımızın gönderdiği kodlar var. Bu kodlarda düzgün çalışıyor. Bu kodlarda aşağıdaki gibi.

Yardımlarınızı için teşekkürler...
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Intersect(Target, Range("a2")) Is Nothing Then Exit Sub
    METİN1 = Range("a2")
    Set FC5 = Range("A3:g10000").Find(What:=METİN1)
    Application.Goto Reference:=Range(FC5.Address), _
       Scroll:=False
    Selection.AutoFilter Field:=1, Criteria1:="*" & METİN1 & "*"
    If METİN1 = "" Then
    Selection.AutoFilter Field:=1
    End If

Call toplam_ekle
End Sub

Sub toplam_ekle()

With Sheets("sayfa1")

    .Range("G4:G" & Rows.Count).ClearContents
    Application.ScreenUpdating = False
    Application.ScreenUpdating = False
    toplam = .Cells(Rows.Count, 1).End(3).Row
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-2]"
    For i = 4 To toplam
    If Not Rows(i).Hidden = True Then
    .Cells(i, "g").Select
    say = ActiveCell.Row
    .Cells(i, "g") = .Cells(say, "g") + (.Cells(i, "e")) - (.Cells(i, "f"))
    .Cells(i, "g") = .Cells(i, "g") + .Range("M1")
    .Range("M1") = .Cells(i, "g")
    End If
    Next
    .Range("M1") = "0"
    Application.ScreenUpdating = True
    Application.ScreenUpdating = True
End With
End Sub
 
Son düzenleme:
Tekrar merhaba.

Yeri gelmişken, otomatik/elle hesaplama seçenekleriyle ilgili bir hususu belirteyim.

Hesaplama yöntemini excel menüsü üzerinden kendiniz veya kod satırı ile MANUAL/ELLE haline getirdiğinizde,
ille de hesaplama yapılması gereken sayfa/alan varsa;

Kod: 
Sheets("[COLOR="blue"]sayfa adı[/COLOR]").Calculate
[COLOR="Red"]veya[/COLOR]
Sheets("[COLOR="Blue"]sayfa adı[/COLOR]").Range("[COLOR="blue"]hücre aralığı[/COLOR]").Calculate
şeklinde bir kod satırı ile sadece belirtilen hücre aralığındaki hesaplamalar da yaptırılabilir.
.
 
Yeri gelmişken buda bu konuya ek bir örnek olabilir
Korhan Beyin yayınladığı altarnatif kod...

Korhan Ayhan' Alıntı:
Deneyiniz.

Kod: 
Option Explicit

Sub Topla()
    Dim S1 As Worksheet, Dizim(), Veri(), Kriter As Variant
    Dim X As Long, Satir As Long, Zaman As Double, Bakiye As Double
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set S1 = Sheets("DEPO")
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
        
    Satir = S1.Cells(S1.Rows.Count, 1).End(3).Row
    S1.Range("F5:H" & Satir).Clear
    Veri = S1.Range("A5:C" & Satir).Value
    
    Kriter = S1.Range("C1").Value
    Bakiye = 0
    
    ReDim Dizim(1 To UBound(Veri, 1), 1 To 3)
    
    For X = 1 To UBound(Veri, 1)
        ReDim Preserve Dizim(1 To UBound(Veri, 1), 1 To 3)
        If Veri(X, 1) = Kriter Then
            Dizim(X, 1) = Bakiye + Veri(X, 2) + Veri(X, 3)
            Bakiye = Dizim(X, 1)
        End If
    Next
    
    S1.Range("H5:H" & UBound(Dizim) + 4) = Dizim
    S1.Range("A4:C" & Satir).AutoFilter 1, Kriter

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With

    Set S1 = Nothing

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000"), vbInformation
End Sub
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst