Hesap toplamların alınması hk.

[1903emre34@gmail.com]

Merhaba,

Ana hesaplarının karşısındaki kümüle bakiye tutarların toplayıp (sarı işaretli alanları), sayfa2 aktarılması için kod oluşutrabiliriz.


Kumüle bakiye eksi tutarlar olduğu zaman sayfa2'de rapor dönemi alacak bakiye tutarların yerleştirilmesi, pozitif tutarların sayfa2De rapor dönemi borç bakiyesine yerleştirilmesi , istenen sayfa2'de yapılmıştır.

 

[1903emre34@gmail.com]

Konu güncel.

 

[Zeki Gürsoy]

Kodu test edin...

[SIZE=2]Sub test()
    Set rs = CreateObject("ADODB.Recordset")

    With rs
        .Fields.Append "kod", 3
        .Fields.Append "borc", 5
        .Fields.Append "alacak", 5
        .Fields.Append "bakiye", 5
        .Fields(1).NumericScale = 2
        .Fields(2).NumericScale = 2
        .Fields(3).NumericScale = 2
        .Open
    End With
    
    For i = 4 To Sayfa1.[b100000].End(3).Row Step 3
    
        If Sayfa1.Cells(i, "I") > 0 Then
        
            rs.Filter = "kod=" & Left(Sayfa1.Cells(i, "b"), 3)
            
            If rs.RecordCount = 0 Then
            
                rs.AddNew Array("kod", "borc", "alacak", "bakiye"), _
                          Array(Left(Sayfa1.Cells(i, "b"), 3), CDbl(Sayfa1.Cells(i, "I")), 0, CDbl(Sayfa1.Cells(i, "I")))
                
            Else
            
                rs(1) = rs(1) + Sayfa1.Cells(i, "I")
                rs(3) = rs(3) + Sayfa1.Cells(i, "I")
                
            End If
            
        ElseIf Sayfa1.Cells(i, "I") < 0 Then
            
            rs.Filter = "kod=" & Left(Sayfa1.Cells(i, "b"), 3)
            
            If rs.RecordCount = 0 Then
            
                rs.AddNew Array("kod", "borc", "alacak", "bakiye"), _
                          Array(Left(Sayfa1.Cells(i, "b"), 3), 0, Abs(CDbl(Sayfa1.Cells(i, "I"))), Abs(CDbl(Sayfa1.Cells(i, "I"))))
                
            Else
            
                rs(2) = rs(2) + Abs(CDbl(Sayfa1.Cells(i, "I")))
                rs(3) = rs(3) + Abs(CDbl(Sayfa1.Cells(i, "I")))
                
            End If
            
        End If
        
    Next
    
    rs.Filter = 0
    
    Sayfa2.[d6].CopyFromRecordset rs
End Sub[/SIZE]

 

[1903emre34@gmail.com]

Teşekkürler, sorunsuz çalışıyor