Aynı değeri içeren hücrelere birleştir ve ortala yapmak.

[limestone]

Herkese merhaba. Öncelikle arama yaptım ama bulamadım. Sorunum A sütununda alt alta olan hücrelerden verileri aynı olanlara birleştir ve ortala uygulamak.1. Butona tıkladığımda birleştir ve ortala yapsın, 2. butona tıkladığımda hücreleri tekrar ayırsın. Örnek dosya ektedir. Şimdiden teşekkür ederim.

Dosya

 

[Bulmacaa]

Konu güncel. Bende aynı sorunun cevabını merak ediyorum

 

[YUSUF44]

Aşağıdaki makroları kullanın:

Sub birlestir()
son = Cells(Rows.Count, "A").End(3).Row
a = 0
For i = son To 1 Step -1
    If Cells(i, "A") = Cells(i + 1, "A") Then
        Range("A" & i & ":A" & i + 1).Select
        Application.DisplayAlerts = False
        Range("A" & i & ":A" & i + 1).Merge
        Application.DisplayAlerts = True
        a = 0
    End If
Next
End Sub
Sub ayır()
a = [A1].CurrentRegion.Count
Range("A:A").UnMerge
For i = 1 To a
    If Cells(i, "A") = "" Then
        Cells(i, "A") = Cells(i - 1, "A")
    End If
Next
End Sub

 

[ASLAN7410]

Sayın Yusuf Bey, hayırlı cumalar diliyorum, kod gayet güzel çalışıyor ellerinize sağlık.

Küçük bir sorun var, Birleştir butonuna bastığımda kod güzel çalışıyor, ayır butonuna bastığımda en son rakamı fazladan çoğaltıyor.

 

[YUSUF44]

Verdiğim kodda B sütununda veri olmadığı düşünülerek düzenleme yapılmıştı. Sizin dosyanızda B sütununda da veri olduğundan ordaki hücreleri de hesaba katıyor.
Öğleden sonra çözüm bulmaya çalışırım.

 

[ASLAN7410]

Tamamdır Yusuf bey, çözümünüzü bekliyorum.

 

[Bulmacaa]

Çok teşekkür ederim. Yusuf bey elinize sağlık

 

[YUSUF44]

Aşağıdaki gibi dener misiniz?

Sub birlestir()
son = Cells(Rows.Count, "A").End(3).Row
a = 0
For i = son To 1 Step -1
    If Cells(i, "A") = Cells(i + 1, "A") Then
        Application.DisplayAlerts = False
        Range("A" & i & ":A" & i + 1).Merge
        Application.DisplayAlerts = True
        a = 0
    End If
Next
End Sub

Sub ayır()
a = Cells(Rows.Count, "A").End(3).Row
Cells(a, "A").Select
b = Selection.Count

Range("A:A").UnMerge
For i = 1 To a + b - 1
    If Cells(i, "A") = "" Then
        Cells(i, "A") = Cells(i - 1, "A")
    End If
Next
End Sub

 

[ASLAN7410]

Sayın Yusuf Bey, ellerinize sağlık çok teşekkür ediyorum, tam istediğim gibi çalışıyor.

Hayırlı günler diliyorum.

 

[DelininBiri]

https://hizliresim.com/5ynhu7u
merhaba. resimde görüldüğü gibi, eğer 4 hücrede aynı harf varsa, tek hücreye otomatik dönüşsün diye bir formül olur mu acaba.
eğer mümkün olursa bunu sayfaya uyarlayacağım