• DİKKAT

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

Raporlama

I

iplikci_80

Katılım
29 Kasım 2007
Mesajlar
1,110
Excel Vers. ve Dili
excel 2007
Arkadaşlar merhabalar EK 'te gönderdiğim çalışmanın; "KASA" sayfasının B sütunundaki harcama kalemlerine göre şablon oluşturan ve harcama verilerini o şablonlara aktarana bir KASA çalışması var. Benim yapmak istediğim şey mevcut kodlara dokunmadan KASA sayfasının A sütunundaki tarihleri dikkate alarak istediğim tarih ve tarih aralığında bir raporlama yapmak istiyorum, bu hususta yardımlarınıza ihtiyacım var. Yardımlarınız için şimdiden çok teşekkür ederim.
 

Ekli dosyalar

iplikci_80' Alıntı:
Arkadaşlar merhabalar EK 'te gönderdiğim çalışmanın; "KASA" sayfasının B sütunundaki harcama kalemlerine göre şablon oluşturan ve harcama verilerini o şablonlara aktarana bir KASA çalışması var. Benim yapmak istediğim şey mevcut kodlara dokunmadan KASA sayfasının A sütunundaki tarihleri dikkate alarak istediğim tarih ve tarih aralığında bir raporlama yapmak istiyorum, bu hususta yardımlarınıza ihtiyacım var. Yardımlarınız için şimdiden çok teşekkür ederim.
Genişletmek için tıkla ...

eki dosya.tc sitesine yüklersen yardımcı olabilirim
 
Merhabalar,


İstemiş olduğunuz K A S A sayfa sekmesinde bulunan verileri tarihleri baz alarak farklı bir sayfa açıp orda listeleme yapılacak doğrumu anladım.

İşlerim yoğun akşam üzere nasip olursa bakarım.
 
Vedat Bey merhabalar ilginize çok teşekkür ederim. İstediğim şey RAPOR sayfasını ayrı bir çalışma sayfası olarak kabul edilerek, gönderdiğiniz TEST çalışması mantığı ile raporlamak istediğim tarihleri yazmak ve raporlamak. Sizin gönderdiğiniz TEST çalışmasında tarihleri değiştirdiğimde veriler raporlanmıyor. EK 'te ki çalışma gibi.
 

Ekli dosyalar

Son düzenleme:
Arkadaşlar yardımlarınızı bekliyorum. Lütfen.
 
Son düzenleme:
Selamlar,

İşlerim çok yoğun müsayit olunca bakarım inşAllah.
 
RAPOR isimli dosyanıza aşağıdaki kodu uygulayıp deneyiniz.

Kod: 
Option Explicit

Sub RAPOR()
    Dim Yol As String, Dosya As String
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Tarih1 As Date, Tarih2 As Date, Liste(), Satir As Long
    Dim Zaman As Double, Son As Long, Say As Long, X As Long
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("RAPOR")
    
    Tarih1 = S1.Range("XFC1").Value
    Tarih2 = S1.Range("XFD1").Value
  
    S1.Range("A2:G" & S1.Rows.Count).ClearContents
    S1.Range("A2:G" & S1.Rows.Count).Borders.LineStyle = 0
    
    Yol = K1.Path
    Dosya = Yol & "\K A S A.xlsm"
    
    Set K2 = Workbooks.Open(Dosya, False, False)
    Set S2 = K2.Sheets("K A S A")
    
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    Say = 1
    
    Liste = S2.Range("A2:G" & Son).Value
    
    ReDim Veri(1 To Son, 1 To 7)
    
    Veri(1, 1) = ""
    Veri(1, 2) = "Devir"
    Veri(1, 3) = 0
    Veri(1, 4) = 0
    Veri(1, 5) = 0
    Veri(1, 6) = ""
    Veri(1, 7) = ""
    
    For X = LBound(Liste) To UBound(Liste)
        If Liste(X, 1) >= Tarih1 And Liste(X, 1) <= Tarih2 Then
            Say = Say + 1
            Veri(Say, 1) = Liste(X, 1)
            Veri(Say, 2) = Liste(X, 2)
            Veri(Say, 3) = Liste(X, 3)
            Veri(Say, 4) = Liste(X, 4)
            Veri(Say, 6) = Liste(X, 6)
            Veri(Say, 7) = Liste(X, 7)
        Else
            If Liste(X, 1) < Tarih1 Then
                On Error Resume Next
                Veri(1, 1) = ""
                Veri(1, 2) = "Devir"
                Veri(1, 3) = Veri(1, 3) + Liste(X, 3)
                Veri(1, 4) = Veri(1, 4) + Liste(X, 4)
                Veri(1, 5) = Veri(1, 3) - Veri(1, 4)
                Veri(1, 6) = ""
                Veri(1, 7) = ""
                On Error GoTo 0
            End If
        End If
    Next

    If Say > 0 Then
        S1.Range("A2").Resize(Say, 7) = Veri
        On Error Resume Next
        For X = 3 To Say + 1
            S1.Cells(X, "E") = S1.Cells(X, "C") - S1.Cells(X, "D") + S1.Cells(X - 1, "E")
        Next
        On Error GoTo 0
        S1.Range("A1:G" & Say + 1).Borders.LineStyle = 1
    End If
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    
    S1.Range("A:G").EntireColumn.AutoFit
    K2.Close 0
      
    Set S1 = Nothing
    Set S2 = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
  
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Korhan Bey ilginize çok teşekkür ederim, ama RAPOR sayfasına veriler aktarılınca hücrelerin kenarlıklarını kaldırılması hususunda yardımlarınızı rica ediyorum.
 
Kenarlık istemiyor musunuz?
 
RAPOR isimli dosyanızda varsa kenarlıkları kaldırıp aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit

Sub RAPOR()
    Dim Yol As String, Dosya As String
    Dim K1 As Workbook, K2 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Tarih1 As Date, Tarih2 As Date, Liste(), Satir As Long
    Dim Zaman As Double, Son As Long, Say As Long, X As Long
    
    Zaman = Timer
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("RAPOR")
    
    Tarih1 = S1.Range("XFC1").Value
    Tarih2 = S1.Range("XFD1").Value
  
    S1.Range("A2:G" & S1.Rows.Count).ClearContents
    
    Yol = K1.Path
    Dosya = Yol & "\K A S A.xlsm"
    
    Set K2 = Workbooks.Open(Dosya, False, False)
    Set S2 = K2.Sheets("K A S A")
    
    Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
    Say = 1
    
    Liste = S2.Range("A2:G" & Son).Value
    
    ReDim Veri(1 To Son, 1 To 7)
    
    Veri(1, 1) = ""
    Veri(1, 2) = "Devir"
    Veri(1, 3) = 0
    Veri(1, 4) = 0
    Veri(1, 5) = 0
    Veri(1, 6) = ""
    Veri(1, 7) = ""
    
    For X = LBound(Liste) To UBound(Liste)
        If Liste(X, 1) >= Tarih1 And Liste(X, 1) <= Tarih2 Then
            Say = Say + 1
            Veri(Say, 1) = Liste(X, 1)
            Veri(Say, 2) = Liste(X, 2)
            Veri(Say, 3) = Liste(X, 3)
            Veri(Say, 4) = Liste(X, 4)
            Veri(Say, 6) = Liste(X, 6)
            Veri(Say, 7) = Liste(X, 7)
        Else
            If Liste(X, 1) < Tarih1 Then
                On Error Resume Next
                Veri(1, 1) = ""
                Veri(1, 2) = "Devir"
                Veri(1, 3) = Veri(1, 3) + Liste(X, 3)
                Veri(1, 4) = Veri(1, 4) + Liste(X, 4)
                Veri(1, 5) = Veri(1, 3) - Veri(1, 4)
                Veri(1, 6) = ""
                Veri(1, 7) = ""
                On Error GoTo 0
            End If
        End If
    Next

    If Say > 0 Then
        S1.Range("A2").Resize(Say, 7) = Veri
        On Error Resume Next
        For X = 3 To Say + 1
            S1.Cells(X, "E") = S1.Cells(X, "C") - S1.Cells(X, "D") + S1.Cells(X - 1, "E")
        Next
        On Error GoTo 0
    End If
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
    
    S1.Range("A:G").EntireColumn.AutoFit
    K2.Close 0
      
    Set S1 = Nothing
    Set S2 = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
  
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
End Sub
 
Korhan Bey her şey için çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst