Tablo sonuna toplam aldırmak

[sahika51]

Merhabalar kıymetli excel.web. ailesi. Ekte sunduğum tablo programında "Bilgi" sayfasında yer alan bilgileri aktar dediğimizde "D" sütununda ki dolu olan hücrelerin bulunduğu satırın bilgileri "Muhasebe" sayfasına aktarılıyor. Buraya kadar sorun yok. "Muhasebe sayfasına gelen ödenen rakamların toplamı bir alt satırına "E", F ve G sütununa toplaması yapılması gerkiyor. Şimdiden teşekkür ederim.

 

[hasankardas]

Merhabalar,
doğru anladıysam kontrol eder misiniz

 

[sahika51]

Merhabalar,
doğru anladıysam kontrol eder misiniz

Deniyorum ama olmuyor. Ben alttaki isimleri de sildim acaba onlardanmı diye yine olmadı

 

[Greenblacksea53]

Sub aktar()
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False

  
    Sheets("Muhasebe").Range("b3:h50").ClearContents
    sat = 3


    For r = 2 To Worksheets("Bilgi").Cells(Rows.Count, "d").End(3).Row
        If Sheets("Bilgi").Cells(r, "d").Value > 0 Then
            For i = 2 To 35
                Sheets("Muhasebe").Cells(sat, i).Value = Sheets("Bilgi").Cells(r, i).Value
            Next i
            sat = sat + 1
        End If
    Next r


    sonSatir = Sheets("Muhasebe").Cells(Rows.Count, "E").End(xlUp).Row

    ' E, F ve G sütunlarına toplamları ekle
    Sheets("Muhasebe").Cells(sonSatir, "E").Formula = "=SUM(E3:E" & sonSatir & ")"
    Sheets("Muhasebe").Cells(sonSatir, "F").Formula = "=SUM(F3:F" & sonSatir & ")"
    Sheets("Muhasebe").Cells(sonSatir, "G").Formula = "=SUM(G3:G" & sonSatir & ")"

    MsgBox "Aktarma işlemi başarıyla gerçekleşti. Kolay Gelsin.", vbInformation, ""

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

Bu şekilde yaparsanız olur.

 

[sahika51]

Sub aktar()
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    Application.ScreenUpdating = False

 
    Sheets("Muhasebe").Range("b3:h50").ClearContents
    sat = 3


    For r = 2 To Worksheets("Bilgi").Cells(Rows.Count, "d").End(3).Row
        If Sheets("Bilgi").Cells(r, "d").Value > 0 Then
            For i = 2 To 35
                Sheets("Muhasebe").Cells(sat, i).Value = Sheets("Bilgi").Cells(r, i).Value
            Next i
            sat = sat + 1
        End If
    Next r


    sonSatir = Sheets("Muhasebe").Cells(Rows.Count, "E").End(xlUp).Row

    ' E, F ve G sütunlarına toplamları ekle
    Sheets("Muhasebe").Cells(sonSatir, "E").Formula = "=SUM(E3:E" & sonSatir & ")"
    Sheets("Muhasebe").Cells(sonSatir, "F").Formula = "=SUM(F3:F" & sonSatir & ")"
    Sheets("Muhasebe").Cells(sonSatir, "G").Formula = "=SUM(G3:G" & sonSatir & ")"

    MsgBox "Aktarma işlemi başarıyla gerçekleşti. Kolay Gelsin.", vbInformation, ""

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

Bu şekilde yaparsanız olur.

Teşekkürederim