birleştir ve ortala yaparak toplattırma

[incsoft]

Arkadaşlar ekteki dosyamda butonumda kodumla otomatik toplatma yaptırıyorum ancak burda benim istediğim tarihlere göre otomatik olarak birleştir ve ortala yaparak toplattırmaktır. Dosyada sarı ile işaretli olan kısımlardan ne demek istediğim daha belli olarak gözükmektedir. 4 tane 02.01.2019 tarihi olduğu için F5:F8 arasını birleştirerek o şekilde toplama yapacak. Amacım her defasında kaç tane aynı tarih olduğunu tespit etmeye gerek kalmadan otomatik olarak tespit ettirerek toplam aldırmaktır.

Teşekkürler..

 

[Ziynettin]

....

Sub birlesik_topla()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Range("F:F").UnMerge
On Error Resume Next
a = Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)
    i = 1
    Do While i <= UBound(a)
        b = a(i, 1)
        say = i
        toplam = 0
        Do While a(i, 1) = b
            Range("F" & say + 1 & ":F" & i + 1).Merge
            i = i + 1
            Range("F" & say + 1 & ":F" & i).Formula = "=sumif(c" & say + 1 & ":c" & i & "," & """>0""" & " )"
            If i > UBound(a) Then Exit Do
        Loop
    Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[incsoft]

....

Sub birlesik_topla()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Range("F:F").UnMerge
a = Range("B2:F" & Cells(Rows.Count, 2).End(3).Row)
    i = 1
    Do While i <= UBound(a)
        b = a(i, 1)
        say = i
        toplam = 0
        Do While a(i, 1) = b
            toplam = toplam + a(i, 2)
            Range("F" & i + 1 & ":F" & say + 1).Merge
            i = i + 1
            If i > UBound(a) Then Exit Do
        Loop
        a(say, 5) = toplam
    Loop
[B2].Resize(UBound(a), UBound(a, 2)) = a
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "İşlem bitti.", vbInformation
End Sub

Hocam çok teşekkür ederim ancak hücrelerde örneğimde de verdiğim gibi excel de komutlarında gözükmesi mümkün değilmidir? Mesela bu durumda sonradan bir değer değiştirdiğimde her defasında yeniden komutu çalıştırmam gerekecektir. Toplam alınan hücrelerde =ETOPLA($C$35:$C$38;">0") şeklinde komutlarda olursa bana çok daha iyi olacaktır.

 

[Ziynettin]

Kod güncellendi. Tekrar deneyiniz.

 

[incsoft]

Kod güncellendi. Tekrar deneyiniz.

çok teşekkürler hocam gerçekten sizler bir numarasınız