• DİKKAT

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

2 Tarih Aralığı ve Hesap Adına Göre İşlemleri Sıralama

Erkan Yılmaz

Erkan Yılmaz

Katılım
3 Kasım 2010
Mesajlar
230
Excel Vers. ve Dili
Excel 2016 - Türkçe
Merhaba Arkadaşlar,

Bir tane hareketleri girdiğimiz "Hareket Girişi" diye sayfamız var. Bütün işlemlerin girişi buraya yapılıyor..

Benim istediğim Bir tane de "Hesap Ekstresi" diye sayfa açtım. Buraya tarih aralığını ve Hesap Adını Listeden seçtiğim zaman; ait olan tarihler aralığında ve o hesaba ait verilerin alt alta gelmesini istiyorum.

Yardımcı olursanız sevinirim.

Dosyanın linkini gönderiyorum.

Şimdiden Teşekkür Ederim.

KİŞİSEL FİNANS DURUMU - Kopya.xlsm - 396 KB
 
Merhaba,

Aşağıdaki kodu deneyiniz.

Kod: 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, Alan As Range, Veri As Range, Satir As Long, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("HAREKET GİRİŞİ")
    Set S2 = Sheets("HESAP EKSTRESİ")
    
    On Error Resume Next
    S1.ShowAllData
    S2.ShowAllData
    On Error GoTo 0
    
    S2.Range("B6:I" & S2.Rows.Count).EntireRow.Delete
    S2.Range("B6:I" & S2.Rows.Count).Borders.LineStyle = xlNone
    Satir = 6
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    
    With S1.Range("C6:I" & S1.Rows.Count)
        .AutoFilter Field:=1, Criteria1:=">=" & CLng(S2.Range("D2")), _
         Operator:=xlAnd, Criteria2:="<=" & CLng(S2.Range("E2"))
        .AutoFilter Field:=3, Criteria1:=S2.Range("D3").Value
    End With
    
    On Error Resume Next
    Set Alan = S1.Range("B5:I" & Son).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not Alan Is Nothing Then
        For Each Veri In Alan
            If Veri.Column = 3 And Veri.Row > 6 Then
                S2.Cells(Satir, 2) = Veri.Offset(0, -1)
                S2.Cells(Satir, 3) = Veri.Offset(0, 0)
                S2.Cells(Satir, 4) = Veri.Offset(0, 3)
                If Veri.Offset(0, 5) = "Borç" Then
                    S2.Cells(Satir, 7) = Veri.Offset(0, 6)
                ElseIf Veri.Offset(0, 5) = "Alacak" Then
                    S2.Cells(Satir, 8) = Veri.Offset(0, 6)
                End If
                If Satir = 6 Then
                    S2.Cells(Satir, 9) = S2.Cells(Satir, 7) - S2.Cells(Satir, 8)
                Else
                    S2.Cells(Satir, 9) = S2.Cells(Satir - 1, 9) + S2.Cells(Satir, 7) - S2.Cells(Satir, 8)
                End If
                Satir = Satir + 1
            End If
        Next
    End If
    
    S2.Range("G2").FormulaLocal = "=TOPLA(DOLAYLI(""G6:G1048576""))"
    S2.Range("H2").FormulaLocal = "=TOPLA(DOLAYLI(""H6:H1048576""))"
    S2.Range("B6:B" & Satir - 1).NumberFormat = "00000"
    S2.Range("B6:B" & Satir - 1).HorizontalAlignment = xlLeft
    S2.Range("C6:C" & Satir - 1).NumberFormat = "m/d/yyyy"
    S2.Range("C6:C" & Satir - 1).HorizontalAlignment = xlLeft
    S2.Range("G6:I" & Satir - 1).NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
    S2.Range("D6:F" & Satir - 1).Merge True
    
    With S2.Range("B5:I" & Satir - 1).Borders
        .LineStyle = 1
        .ColorIndex = 16
        .Weight = xlThin
    End With
    With S2.Range("B6:I" & Satir - 1).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 16
        .Weight = xlHairline
    End With
    
    On Error Resume Next
    S1.ShowAllData
    S2.ShowAllData
    On Error GoTo 0

    S2.Range("B6").Activate

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Çalışmanıza boş bir modül ekleyin. Daha sonra aşağıdaki işlemi uygulayın.

"HESAP EKSTRESİ" isimli sayfanıza bir buton ekleyip kodu bu butona atayın. Butona tıkladığınızda kodlar sonuç verecektir.
 
Korhan Ayhan' Alıntı:
Çalışmanıza boş bir modül ekleyin. Daha sonra aşağıdaki işlemi uygulayın.

"HESAP EKSTRESİ" isimli sayfanıza bir buton ekleyip kodu bu butona atayın. Butona tıkladığınızda kodlar sonuç verecektir.
Genişletmek için tıkla ...

Sevgili Korhan Ayhan Bey,

Beceremedim açıkcası. Düğme ekledim ama kodu ona ekleyemedim.
 
Merhaba Sayın €rK@n.
Sayın AYHAN'ın eklediği kod gayet güzel çalışıyor.

Önce Sayın AYHAN'ın gönderdiği kodu bir MODÜL'e yapıştırın.

Sayfaya eklediğiniz düğme, GELİŞTİRİCİ menüsünde;
-- Üst taraftaki düğme ise düğmeye sağ tıklayıp MAKRO ATA'yı seçtiğinizde Sayın AYHAN'ın gönderdiği AKTAR kod'unu seçmeniz,
-- ActiveX denetimleri kısmındaki düğme ise (CommandButton) o düğmeye sağ tıklayıp KOD GÖRÜNTÜLEyi seçip oraya Call AKTAR diye bir satır yazmanız,
-- Eklediğiniz şey bir şekil veya metin kutusu ise yine buna sağ tıklayıp MAKRO ATAyı seçip açılan ekrandan AKTAR kod'unu seçmeniz
yeterli olacaktır.
 
Ömer BARAN' Alıntı:
Merhaba Sayın €rK@n.
Sayın AYHAN'ın eklediği kod gayet güzel çalışıyor.

Önce Sayın AYHAN'ın gönderdiği kodu bir MODÜL'e yapıştırın.

Sayfaya eklediğiniz düğme, GELİŞTİRİCİ menüsünde;
-- Üst taraftaki düğme ise düğmeye sağ tıklayıp MAKRO ATA'yı seçtiğinizde Sayın AYHAN'ın gönderdiği AKTAR kod'unu seçmeniz,
-- ActiveX denetimleri kısmındaki düğme ise (CommandButton) o düğmeye sağ tıklayıp KOD GÖRÜNTÜLEyi seçip oraya Call AKTAR diye bir satır yazmanız,
-- Eklediğiniz şey bir şekil veya metin kutusu ise yine buna sağ tıklayıp MAKRO ATAyı seçip açılan ekrandan AKTAR kod'unu seçmeniz
yeterli olacaktır.
Genişletmek için tıkla ...

Sevgili Ömer BARAN Bey,

Öncelikle Teşekkür Ederim. Tarifiniz ile kodu çalıştırdım. Ancak Hesap Ekstresi sayfasında bir düzenleme yapınca satır sayılarından dolayı sanırım kod çalışmaz oldu. Birde verinin olduğu kadar hücreler çizgi olabilir mi acaba?

Son halini gönderiyorum incelerseniz sevinirim.

KİŞİSEL FİNANS DURUMU - Kopya.xlsm - 404 KB
 
Tekrar merhaba.
Kodu aşağıdaki şekilde değiştirerek kullanın.
Kod: 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, Alan As Range, Veri As Range, Satir As Long, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("HAREKET GİRİŞİ")
    Set S2 = Sheets("HESAP EKSTRESİ")
    
    On Error Resume Next
    S1.ShowAllData
    S2.ShowAllData
    On Error GoTo 0
S2.Range("B6:I65536").Borders.LineStyle = xlNone
    S2.Range("B6:I" & S2.Rows.Count).ClearContents
    
    Satir = 6
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    
    With S1.Range("C6:I" & S1.Rows.Count)
        .AutoFilter Field:=1, Criteria1:=">=" & CLng(S2.Range("D2")), Operator:=xlAnd, Criteria2:="<=" & CLng(S2.Range("E2"))
        .AutoFilter Field:=3, Criteria1:=S2.Range("D3").Value
    End With
    
    On Error Resume Next
    Set Alan = S1.Range("B2:I" & Son).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not Alan Is Nothing Then
        For Each Veri In Alan
            If Veri.Column = 3 And Veri.Row > 6 Then
                S2.Cells(Satir, 2) = Veri.Offset(0, -1)
                S2.Cells(Satir, 3) = Veri.Offset(0, 0)
                S2.Cells(Satir, 4) = Veri.Offset(0, 3)
                If Veri.Offset(0, 5) = "Borç" Then
                    S2.Cells(Satir, 7) = Veri.Offset(0, 6)
                ElseIf Veri.Offset(0, 5) = "Alacak" Then
                    S2.Cells(Satir, 8) = Veri.Offset(0, 6)
                End If
                If Satir = 6 Then
                    S2.Cells(Satir, 9) = S2.Cells(Satir, 7) - S2.Cells(Satir, 8)
                Else
                    S2.Cells(Satir, 9) = S2.Cells(Satir - 1, 9) + S2.Cells(Satir, 7) - S2.Cells(Satir, 8)
                End If
                Satir = Satir + 1
            End If
        Next
    End If
    
    On Error Resume Next
    S1.ShowAllData
    S2.ShowAllData
    On Error GoTo 0

With S2.Range("B6:I" & S2.[B65536].End(3).Row).Borders
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
End With
S2.Range("D6:F6").Select: Selection.Merge
S2.Range("A6:I6").Copy
S2.Range("A6:I" & S2.[B65536].End(3).Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
Cells(5, 2).Activate
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Son düzenleme:
Merhaba,

Sayfa yapınızda değişiklik yaparsanız kodları da revize etmek gerekecektir. Son dosyanıza ve isteklerinize göre #2 nolu mesajımda ki kodu revize ettim. Deneyebilirsiniz.
 
Ömer BARAN' Alıntı:
Tekrar merhaba.
Kodu aşağıdaki şekilde değiştirerek kullanın.
Kod: 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet, Alan As Range, Veri As Range, Satir As Long, Son As Long
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("HAREKET GİRİŞİ")
    Set S2 = Sheets("HESAP EKSTRESİ")
    
    On Error Resume Next
    S1.ShowAllData
    S2.ShowAllData
    On Error GoTo 0
S2.Range("B6:I65536").Borders.LineStyle = xlNone
    S2.Range("B6:I" & S2.Rows.Count).ClearContents
    
    Satir = 6
    Son = S1.Cells(S1.Rows.Count, 3).End(3).Row
    
    With S1.Range("C6:I" & S1.Rows.Count)
        .AutoFilter Field:=1, Criteria1:=">=" & CLng(S2.Range("D2")), Operator:=xlAnd, Criteria2:="<=" & CLng(S2.Range("E2"))
        .AutoFilter Field:=3, Criteria1:=S2.Range("D3").Value
    End With
    
    On Error Resume Next
    Set Alan = S1.Range("B2:I" & Son).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not Alan Is Nothing Then
        For Each Veri In Alan
            If Veri.Column = 3 And Veri.Row > 6 Then
                S2.Cells(Satir, 2) = Veri.Offset(0, -1)
                S2.Cells(Satir, 3) = Veri.Offset(0, 0)
                S2.Cells(Satir, 4) = Veri.Offset(0, 3)
                If Veri.Offset(0, 5) = "Borç" Then
                    S2.Cells(Satir, 7) = Veri.Offset(0, 6)
                ElseIf Veri.Offset(0, 5) = "Alacak" Then
                    S2.Cells(Satir, 8) = Veri.Offset(0, 6)
                End If
                If Satir = 6 Then
                    S2.Cells(Satir, 9) = S2.Cells(Satir, 7) - S2.Cells(Satir, 8)
                Else
                    S2.Cells(Satir, 9) = S2.Cells(Satir - 1, 9) + S2.Cells(Satir, 7) - S2.Cells(Satir, 8)
                End If
                Satir = Satir + 1
            End If
        Next
    End If
    
    On Error Resume Next
    S1.ShowAllData
    S2.ShowAllData
    On Error GoTo 0

With S2.Range("B6:I" & S2.[B65536].End(3).Row).Borders
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
End With
S2.Range("D6:F6").Select: Selection.Merge
S2.Range("A6:I6").Copy
S2.Range("A6:I" & S2.[B65536].End(3).Row).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
Cells(5, 2).Activate
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...

Sevgili Ömer BARAN Bey,

Çok Teşekkür Ederim. Elinize Yüreğinize Sağlık. Şu anda gayet iyi çalışıyor.İyi ki varsınız... Sizlerde olmasanız ne yapacağız bilmiyorum. Çok kısa zamanda sorunlarımızı, sorularımızı çözüme ulaştırıyorsunuz...
 
Korhan Ayhan' Alıntı:
Merhaba,

Sayfa yapınızda değişiklik yaparsanız kodları da revize etmek gerekecektir. Son dosyanıza ve isteklerinize göre #2 nolu mesajımda ki kodu revize ettim. Deneyebilirsiniz.
Genişletmek için tıkla ...

Sevgili Korhan AYHAN Bey,

Çok Teşekkür Ediyorum. Emeğinize Yüreğinize Sağlık. İyi ki varsınız.
 
€rK@n;840326' Alıntı:
Sevgili Ömer BARAN Bey,

Çok Teşekkür Ederim. Elinize Yüreğinize Sağlık. Şu anda gayet iyi çalışıyor.İyi ki varsınız... Sizlerde olmasanız ne yapacağız bilmiyorum. Çok kısa zamanda sorunlarımızı, sorularımızı çözüme ulaştırıyorsunuz...
Genişletmek için tıkla ...
Estağfurullah, ben birşey yapmadım.
Kod'lar Sayın Korhan AYHAN'a ait.
Benim yaptığım; kod'u nasıl çalıştıracağınızı tarif etmek ve birkaç satırlık biçimlendirme kod'u eklemekten ibaret idi.

İyi günler dilerim.
 
Ben tablomda biraz düzenleme yaptım ama tekrardan kodları bozdum sanırım.

Şu anki halini gönderiyorum. Yardımcı olursanız sevinirim.
 
Son düzenleme:
Merhaba.

Kırmızı olan sayıları düzeltin.
Kod: 
    With S1.Range("C6:I" & S1.Rows.Count)
        .AutoFilter Field:=[COLOR="red"][B]2[/B][/COLOR], Criteria1:=">=" & CLng(S2.Range("D2")), Operator:=xlAnd, Criteria2:="<=" & CLng(S2.Range("E2"))
        .AutoFilter Field:=[B][COLOR="Red"]4[/COLOR][/B], Criteria1:=S2.Range("D3").Value
    End With
 
Ömer BARAN' Alıntı:
Merhaba.

Kırmızı olan sayıları düzeltin.
Kod: 
    With S1.Range("C6:I" & S1.Rows.Count)
        .AutoFilter Field:=[COLOR="red"][B]2[/B][/COLOR], Criteria1:=">=" & CLng(S2.Range("D2")), Operator:=xlAnd, Criteria2:="<=" & CLng(S2.Range("E2"))
        .AutoFilter Field:=[B][COLOR="Red"]4[/COLOR][/B], Criteria1:=S2.Range("D3").Value
    End With
Genişletmek için tıkla ...

Sevgili Ömer BARAN Bey,

Teşekkür ederim. Düzelttim sorunu. Birde hücre çizgilerini nasıl ayarlayabilirim. Veri geldiği zaman hücre çizgisinin rengi düz olmasını ve gri olmasını istiyorum.
 
Son düzenleme:
Hatalı cevabı ve ekini sildim.

Yeni belge sayfadaki son cevabımda.
 
Son düzenleme:
Denemeler yaparken sorun oldu sanırım.

Belgenin içine açıklama yazdım.

Yeni belge BURADA.
 
Ömer BARAN' Alıntı:
Denemeler yaparken sorun oldu sanırım.

Belgenin içine açıklama yazdım.

Yeni belge BURADA.
Genişletmek için tıkla ...

Teşekkür ediyorum. Sorunu hallettim sayenizde...

Kodlar için Korhan AYHAN beye,

Yardımlarını benden hiç esirgemeyen Ömer BARAN beye,

Çok çok teşekkürlerimi iletiyorum.

Forum ve bizler için iyi ki varsınız.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst