makro ile alttoplam aldırma

[shuker]

Sub AltToplamAl()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim toplam As Double

' Aktif çalışma sayfasını al
Set ws = ActiveSheet

' Son dolu satırı bul
lastRow = ws.Cells(ws.Rows.Count, "J").End(xlUp).Row

' Satır satır ilerleyerek alt toplamları al
For i = lastRow To 1 Step -1
' Boş satır kontrolü
If IsEmpty(ws.Cells(i, "J").Value) Then
' Boş satır bulundu, bir üstteki boş satıra kadar olan aralığı topla
toplam = 0
For j = i - 1 To 1 Step -1
If IsNumeric(ws.Cells(j, "J").Value) Then
toplam = toplam + ws.Cells(j, "J").Value
Else
Exit For
End If
Next j

' J sütunundaki hücreye toplamı yaz
ws.Cells(i, "J").Value = toplam
End If
Next i
End Sub
Arkadaşlar merhaba,

300 satır verim var ve bazı verilerin altında boş satırlarım var. bu boş satırlar dinamik. yani bazen 3 satır dolu 1 boş bazen 1 satır dolu 1 boş gibi. boş satırlar her zaman tek satır. yukarıdaki kod bu boş satırların J sütununa alt toplam aldırıyor fakat, bir satır fazla topluyor. örnek dosya ekliyorum orada modülü 3 te bu kod görünecektir. bunu doğru alt toplam alabilmem için kodda nasıl bir değişiklik yapmam gerekiyor. yardımcı olabilirmisiniz

örnek dosya :

İndir Melike

Dosyayı indir Melike

dosya.co

 

[Muzaffer Ali]

Merhaba.

Sub Test()
    Dim Bak As Long
    Dim Toplam As Double
    For Bak = 3 To Cells(Rows.Count, "J").End(xlUp).Row
        If Not IsEmpty(Cells(Bak, "J")) Then
            Toplam = Toplam + Cells(Bak, "J")
        Else
            Cells(Bak, "J") = Toplam
            Toplam = 0
        End If
    Next
    MsgBox "Tamamlandı."
End Sub

 

[Erkan Akayay]

Sizin kodda boş hücreye odaklandığı için toplam alınan hücre boş olmadığı için toplama ekliyordu.

 

[shuker]

Merhaba.

Sub Test()
    Dim Bak As Long
    Dim Toplam As Double
    For Bak = 3 To Cells(Rows.Count, "J").End(xlUp).Row
        If Not IsEmpty(Cells(Bak, "J")) Then
            Toplam = Toplam + Cells(Bak, "J")
        Else
            Cells(Bak, "J") = Toplam
            Toplam = 0
        End If
    Next
    MsgBox "Tamamlandı."
End Sub

hocam kod tam istediğim gibi fakat en alttaki satırların toplamını almıyor onuda çözersek sorunum kalmayacak. elinize sağlık

 

[Erkan Akayay]

For Bak = 3 To Cells(Rows.Count, "J").End(xlUp).Row
satırını
For Bak = 3 To Cells(Rows.Count, "J").End(xlUp).Row+1
yapın

 

[shuker]

For Bak = 3 To Cells(Rows.Count, "J").End(xlUp).Row+1

Erkan Bey teşekkür ederim atlamışım +1 satır eklemeyi.

Sorunum çözülmüştür. Sanırım konunun kilitlenmesi gerekiyor.

 

[mannis]

For Bak = 3 To Cells(Rows.Count, "J").End(xlUp).Row
satırını
For Bak = 3 To Cells(Rows.Count, "J").End(xlUp).Row+1
yapın

Arkadaşlar çok güzel olmuş, elinize emeğinize sağlık,
Sizden ricam toplam yaptırdığımız hücrelere toplam değeri yerine formül yazdırabilir miyiz?
Yardımcı olursanız çok sevinirim arkadaşlar, şimdiden teşekkürler iyi çalışmalar.

 

[Muzaffer Ali]

Arkadaşlar çok güzel olmuş, elinize emeğinize sağlık,
Sizden ricam toplam yaptırdığımız hücrelere toplam değeri yerine formül yazdırabilir miyiz?
Yardımcı olursanız çok sevinirim arkadaşlar, şimdiden teşekkürler iyi çalışmalar.

Deneyiniz.

Sub Test()
    Dim Bak As Long
    Dim BosHucre As Range
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    For Bak = Cells(Rows.Count, "J").End(xlUp).Row + 1 To 3 Step -1
        If IsEmpty(Cells(Bak, "J")) Then
            Set BosHucre = Cells(Bak, "J")
        Else
            BosHucre.Formula = "=Sum(J" & Bak & ":" & BosHucre.Offset(-1, 0).Address(False, False) & ")"
        End If
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
    MsgBox "Tamamlandı."
End Sub

 

[shuker]

Deneyiniz.

Sub Test()
    Dim Bak As Long
    Dim BosHucre As Range
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    For Bak = Cells(Rows.Count, "J").End(xlUp).Row + 1 To 3 Step -1
        If IsEmpty(Cells(Bak, "J")) Then
            Set BosHucre = Cells(Bak, "J")
        Else
            BosHucre.Formula = "=Sum(J" & Bak & ":" & BosHucre.Offset(-1, 0).Address(False, False) & ")"
        End If
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
    MsgBox "Tamamlandı."
End Sub

teşekkür ederim Muzaffer Hocam

 

[mannis]

Deneyiniz.

Sub Test()
    Dim Bak As Long
    Dim BosHucre As Range
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    For Bak = Cells(Rows.Count, "J").End(xlUp).Row + 1 To 3 Step -1
        If IsEmpty(Cells(Bak, "J")) Then
            Set BosHucre = Cells(Bak, "J")
        Else
            BosHucre.Formula = "=Sum(J" & Bak & ":" & BosHucre.Offset(-1, 0).Address(False, False) & ")"
        End If
    Next
    Application.ScreenUpdating = True
    Application.Calculation = xlAutomatic
    MsgBox "Tamamlandı."
End Sub

Elinize sağlık, harika olmuş, teşekkürler.