otomatik olarak toplattırma

[incsoft]

Arkadaşlar kullanmış olduğum bir dosyamda sürekli hücre birleştirmesi yaptırarak toplama yaptığım alanlar bulunmaktadır. Buralara sıfırdan farklı olan değerleri toplattırmaktayım. Her defasında elle formül vermek yerine bir butona formül girerek otomatik olarak toplattırmak istiyorum. Bunu ne şekilde yapabiliriz acaba? Birleştirilmiş hücreler farklı olduğundan normal komutlarla yapamadım.

Teşekkürler.

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Topla()

    Dim i As Long, adr As String, a As Byte
    
    Application.ScreenUpdating = False
    Range("B:B").ClearContents
    
    For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
        a = 2
        adr = Cells(i, "B").MergeArea.Address
        Cells(i, "B") = "=Sum(" & Replace(adr, "B", "A") & ")"
        If InStr(adr, ":") > 0 Then a = 4
        i = Split(adr, "$")(a)
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[incsoft]

Öncelikle teşekkürler Ömer bey,

Bazı alanlarda da birleştirmeler mevcut değildir bu durumda da direk örneğin =A39 diyebilirmi? Bu gibi durumda Runtime error "9" Subscript out of range hatası veriyor.

 

[Ömer]

Kodları güncelledim. Tekrar deneyiniz.

.

 

[incsoft]

Bunu kendi dosyama uyarladım nedense yapmıyor

 

[incsoft]

Kodları güncelledim. Tekrar deneyiniz.

.

Ömer bey gayet güzel sizide yoruyorum kusura bakmayın. Burda negatif değerleri işleme almaması için ne yapabiliriz. Örneğin aşağıda ben -28'i işleme almamasını istiyorum. Sadece pozitif değerleri toplasın. Tekrar teşekkürler.
-28,00
25,00
3,00
7,00
6,25

Bunu kendi dosyama uyarladım nedense yapmıyor

 

[Ömer]

Cells(i, "B") = "=Sum(" & Replace(adr, "B", "A") & ")"

yukarıdaki satırın yerine aşağıdaki satırı yazıp deneyin.

Cells(i, "B") = "=SumIf(" & Replace(adr, "B", "A") & "," & """>0""" & ")"

.

 

[incsoft]

Cells(i, "B") = "=Sum(" & Replace(adr, "B", "A") & ")"

yukarıdaki satırın yerine aşağıdaki satırı yazıp deneyin.

Cells(i, "B") = "=SumIf(" & Replace(adr, "B", "A") & "," & """>0""" & ")"

.

Ömer bey en son bir değişiklik yapabilirmiyiz zahmet olmazsa? Range("B:B").ClearContents de formülü Range("F968: F1136").ClearContents uyarladığımda boş olan hücrelere de toplam aldırıyor ve SIFIR(0) olarak atıyor. Burada sadece dolu hücreler nasıl toplatabilirim? Kendi dosyamın formülü

Private Sub CommandButton1_Click()
Dim i As Long, adr As String, a As Byte

Application.ScreenUpdating = False
Range("F968: F1136").ClearContents

For i = 1 To Cells(Rows.Count, "C").End(xlUp).Row
a = 2
adr = Cells(i, "F").MergeArea.Address
Cells(i, "F") = "=SumIf(" & Replace(adr, "F", "C") & "," & """>0""" & ")"
If InStr(adr, ":") > 0 Then a = 4
i = Split(adr, "$")(a)
Next i

Application.ScreenUpdating = True
End Sub

Teşekkürler.

 

[Ömer]

Sorunuz tam anlaşılmıyor. Örnek dosya ekleyerek daha detaylı açıklama yapar mısınız.

.

 

[incsoft]

Sorunuz tam anlaşılmıyor. Örnek dosya ekleyerek daha detaylı açıklama yapar mısınız.

.

Bir türlü çözemedim arkadaşlar.

Çok teşekkürler..

 

[Ömer]

For i = 1 To Cells(Rows.Count, "C").End(xlUp).Row

Kırmızı işaretli bölümü B yaparak deneyin.

.