Birleştirilmiş hücrede toplama işlemi

[dgdizayn]

Merhabalar,

Ekteki dosyada, A sütununda aynı sayılar yada kelimeler var ise, aynı kelimelerin yada sayıların olduğu satırda D sütunundaki hücreleri birleştir olayını yapıyor. Bu D sütunundaki butona bastığımızda birleşen hücreler 10,10,10 şeklinde. Bu butona basında birleşen hücreye, birleştirdiği kadar toplasın istiyorum. Örneğin burada 10,10,10 birleşiyor ve burada 30 yazsın istiyorum. Mümkün müdür acaba, teşekkürler.



Makro kodlar

Sub Aynı_Hücreleri_Birleştir()
    Dim Rky As Integer, Ert As Integer, a As Integer
  
    Application.DisplayAlerts = False
    On Error Resume Next
    For Rky = Range("A65536").End(3).Row To 1 Step -1
        If Cells(Rky, "D").MergeCells = True Then
            Ert = Rky
        Exit For
    End If
    Next Rky

    For a = Range("A65536").End(3).Row To Ert Step -1
        If Cells(a, "A") = Cells(a - 1, "A") Then
            Range(Cells(a, "D"), Cells(a - 1, "D")).Merge
        End If
    Next a
    Application.DisplayAlerts = True
    Rky = Empty: Ert = Empty: a = Empty
End Sub

 

[muratboz06]

Deneyiniz.

Sub Aynı_Hücreleri_Birleştir()
    Dim Rky As Integer, Ert As Integer, a As Integer
  
    Application.DisplayAlerts = False
    On Error Resume Next
    For Rky = Range("A65536").End(3).Row To 1 Step -1
        If Cells(Rky, "D").MergeCells = True Then
            Ert = Rky
        Exit For
    End If
    Next Rky

    For a = Range("A65536").End(3).Row To Ert Step -1
        If Cells(a, "A") = Cells(a - 1, "A") Then
        Cells(a - 1, 4) = Cells(a, 4) + Cells(a - 1, 4) 'D sütununda hücreleri birleştirmeden önce hücre değerlerini toplar.
            Range(Cells(a, "D"), Cells(a - 1, "D")).Merge
        End If
    Next a
    Application.DisplayAlerts = True
    Rky = Empty: Ert = Empty: a = Empty
End Sub

 

[dgdizayn]

Deneyiniz.

Sub Aynı_Hücreleri_Birleştir()
    Dim Rky As Integer, Ert As Integer, a As Integer
 
    Application.DisplayAlerts = False
    On Error Resume Next
    For Rky = Range("A65536").End(3).Row To 1 Step -1
        If Cells(Rky, "D").MergeCells = True Then
            Ert = Rky
        Exit For
    End If
    Next Rky

    For a = Range("A65536").End(3).Row To Ert Step -1
        If Cells(a, "A") = Cells(a - 1, "A") Then
        Cells(a - 1, 4) = Cells(a, 4) + Cells(a - 1, 4) 'D sütununda hücreleri birleştirmeden önce hücre değerlerini toplar.
            Range(Cells(a, "D"), Cells(a - 1, "D")).Merge
        End If
    Next a
    Application.DisplayAlerts = True
    Rky = Empty: Ert = Empty: a = Empty
End Sub

Sn. Muratboz06,

Emeğinize ellerinize sağlık. Bu kadar kısa sürede çözüm için ayrıca teşekkür ederim.

 

[dgdizayn]

Merhabalar tekrardan,

Birşey farkettim, A sütununa belli kelimeler yazdığımda aynı olan kelimeleri tespit edip D sütununda birleştiriyor. Örneğin; "kelime cümle" olduğunda sorun yok fakat "kelime-cümle" yada "kelime,cümle" gibi aralarında özel karakterler olduğunda tespit edip birleştiremiyor. Bu konuda bir çözüm bulabilir miyiz acaba.

Teşekkürler.

 

[Korhan Ayhan]

Bu gayet normal bir durum..

Çünkü makronuzda EŞİTLİK sorgulanıyor. Doğal olarak "kelime cümle" ifadesi "kelime-cümle" ifadesi farklı (tire işaretinden dolayı) yorumlanıyor.

Aynı yorumlanması için özel karakterleri boşlukla değiştirebilirsiniz.

Bu satırı;

If Cells(a, "A") = Cells(a - 1, "A") Then

Aşağıdaki gibi değiştirip deneyiniz.

If Replace(Cells(a, "A"), "-", " ") = Replace(Cells(a - 1, "A"), "-", " ") Then

Bu değişim sadece "tire" işareti için çalışacaktır. Başka özel işaretler varsa onlarıda aynı şekilde koda eklemelisiniz.

 

[dgdizayn]

Bu gayet normal bir durum..

Çünkü makronuzda EŞİTLİK sorgulanıyor. Doğal olarak "kelime cümle" ifadesi "kelime-cümle" ifadesi farklı (tire işaretinden dolayı) yorumlanıyor.

Aynı yorumlanması için özel karakterleri boşlukla değiştirebilirsiniz.

Bu satırı;

If Cells(a, "A") = Cells(a - 1, "A") Then

Aşağıdaki gibi değiştirip deneyiniz.

If Replace(Cells(a, "A"), "-", " ") = Replace(Cells(a - 1, "A"), "-", " ") Then

Bu değişim sadece "tire" işareti için çalışacaktır. Başka özel işaretler varsa onlarıda aynı şekilde koda eklemelisiniz.

Sn. Korhan Ayhan Bey,

Hızlı ve çözüm odaklı yanıtınız için teşekkür ederim. O halde;

- , / gibi işaretler için If Replace(Cells(a, "A"), "-", ",","/"," ") = Replace(Cells(a - 1, "A"), "-", ",","/"," ") Then

şeklinde yapıyorum, doğru mudur.

 

[Korhan Ayhan]

Hayır doğru değildir.

İç içe yazmalısınız..

Replace(Replace(......

 

[Korhan Ayhan]

Aşağıdaki gibi yapmalısınız..

If Replace(Replace(Replace(Cells(a, "A"), "-", " "), ",", " "), "/", " ") = Replace(Replace(Replace(Cells(a - 1, "A"), "-", " "), ",", " "), "/", " ") Then

 

[dgdizayn]

Hocam malesef hata verdi niye hata veriyor anlamadım.

 

[Korhan Ayhan]

Küçük bir düzeltme yaptım. Tekrar deneyiniz.

 

[dgdizayn]

Küçük bir düzeltme yaptım. Tekrar deneyiniz.

Sn. Korhan Ayhan Bey,

Çok teşekkürler, emeğinize sağlık.