koşula bağlı hücre birleştirme

[Ergün Güler]

Selam,
Belirli bir koşula, değere veya fonksiyona bağlı olarak hücreleri nasıl birleştirebilirim?
örnek dosyayı ekledim. "B" adlı sayfanın İçinde açıklama da mevcut.
Kolay gelsin.

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub Birlestir()
Dim i As Integer
Application.DisplayAlerts = False
For i = 7 To [A65536].End(3).Row
    If Cells(i, "A") = Cells(i - 1, "A") Then Range("C" & i - 1 & ":C" & i).Merge
Next i
Application.DisplayAlerts = True
End Sub

 

[Ergün Güler]

Sayın Necdet Yeşertener,
Çözüm için ellerinize sağlık. Ancak istenilen şekilde çalışmıyor. Şöye ki;
Dosyayı açtıktan sonra makroyu ilk çalıştırdığımda, istenilen oluyor. Ancak veriler güncellenince istenilen olmuyor. makroyu tekrar çalıştırsam bile önceki hali değişmiyor.
Nasıl çözebiliriz?
iyi çalışmalar.

 

[Ergün Güler]

Selam,
Arkadaşalar acaba bu soruyu makro başlığında mı sorsaydım?

 

[Ergün Güler]

Selam arkadaşlar,
Yardımcı olabilir misiniz?

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub KOŞULA_GÖRE_BİRLEŞTİR()
    Dim X As Long
    
    Application.ScreenUpdating = False
    
    With Range("D7:D" & Range("D65536").End(3).Row)
        .MergeCells = False
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Formula = "=SUMPRODUCT(--(Veriler!$A$3:$A$30=$A7),(Veriler!$E$3:$E$30))"
    End With
    
    For X = 7 To Range("A65536").End(3).Row
        If Cells(X, "A") = Cells(X - 1, "A") Then
            Range(Cells(X, "D"), Cells(X, "D")).ClearContents
            Range(Cells(X, "D"), Cells(X - 1, "D")).Merge
        End If
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Ergün Güler]

Sayın Korhan Ayhan,
Süper olmuş ellerinize sağlık. Ancak önemli bir istediğim var. makro herhangi bir değer değiştiği zaman otomatik çalışsa nasıl olur? yapabilir miyiz?
İyi çalışmalar.

 

[Ergün Güler]

Sayın Korhan Ayhan,
kodu aşağıdaki gibi düzenledim.
tam istediğim gibi çalışıyor. emeğinize sağlık çok teşekkür ederim.
Bir sorum daha olacak. A sütunundaki veriler değişince otomatik birleştirme yapılıyor.
ancak, A sütunundaki verileri başka sayfadan formülle aldığım zaman otomatik birleştirme yapmıyor, sadece hücrelerde gezerken otomatik yapıyor. A sütunundaki hücrelerde bulunan formul sonuçları değiştiği zaman otomatik birleştirme nasıl sağlayabilirim?
iyi çalışmalar.
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim X As Long

Application.ScreenUpdating = False

With Range("D7" & Range("D65536").End(3).Row)
.MergeCells = False
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Formula = "=SUMPRODUCT(--(Veriler!$A$3:$A$30=$A7),(Veriler!$E$3:$E$30))"
End With

For X = 7 To Range("A65536").End(3).Row
If Cells(X, "A") = Cells(X - 1, "A") Then
Range(Cells(X, "D"), Cells(X, "D")).ClearContents
Range(Cells(X, "D"), Cells(X - 1, "D")).Merge
End If
Next

Application.ScreenUpdating = True

End Sub

 

[Korhan Ayhan]

Selamlar,

Formüllerin sonucu değiştiğinde kodun çalışması için aşağıdaki olayları deneyebilirsiniz.

Private Sub Worksheet_Activate() 'Sayfa aktif olduğunda
Private Sub Worksheet_Calculate() 'Hesaplama moduna geçildiğinde

Yada kullandığınız kodu formüllerin başvurduğu kaynak sayfaya uygularsınız. Kod içindeki hücre adreslerine sayfa adınıda eklersiniz böylelikle formülleri tetikleyen hücreler değiştikçe diğer sayfadaki hücreler buna göre biçimlenecektir.

 

[Ergün Güler]

Çok teşekkürler. Sayın Korhan Ayhan,

 

[Ergün Güler]

Sayın Korhan Ayhan,
Örneğinizi asıl dosyama uyarladım ancak, yapamadım. Sizin kodları gönderdiğim örnek dosyada uygulayınca oluyor.
Şöyle bir yanlış anlaşılma olabilir;
Örnek dosyamda C ve D sütunları var. C sütununu silince dosya çalışmıyor.
Şöyle farz edelim C sütunu olmasın. Birleştirilmesi gereken hücreler D sütununda ve D sütununda formüller var.
Şimdiden çok teşekkür ederim.
İyi çalışmalar.

 

[Ergün Güler]

Selam Arkadaşlar,

 

[Korhan Ayhan]

Selamlar,

Zaten kod D sütununda birleştirme işlemi yapıyor.

 

[Ergün Güler]

Sayın Korhan Ayhan,
Asıl dosyama uyarlamaya biraz çalıştım. Ancak,
.Formula = "=IF(ROWS(O$7:O7)>$H$1,"",SUMPRODUCT(--(ikayıt=A7),(insört2009!$O$3:$O$342))/COUNTIF(ikayıt,$A7))"
kısmında hata veriyor.

fonksiyonun türkçesi:
=EĞER(SATIRSAY(O$7:O7)>$H$1;"";TOPLA.ÇARPIM(--(ikayıt=A7);(insört2009!$O$3:$O$342))/EĞERSAY(ikayıt;$A7))

; yerine , kullandım. türkçeleri eng. yaptım. nerede yanlış yapıyorum acaba?

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki şekilde denermisiniz.

"=IF(ROWS(O$7:O7)>$H$1,[COLOR=red]""""[/COLOR],SUMPRODUCT(--(ikayıt=A7),(insört2009!$O$3:$O$342))/COUNTIF(ikayıt,$A7))"

 

[Ergün Güler]

Selamlar,

Aşağıdaki şekilde denermisiniz.

"=IF(ROWS(O$7:O7)>$H$1,[COLOR=red]""""[/COLOR],SUMPRODUCT(--(ikayıt=A7),(insört2009!$O$3:$O$342))/COUNTIF(ikayıt,$A7))"

Sayın Korhan Ayhan,
verdiğiniz şekilde formülü girince mükemmel çalıştı. çok teşekkür ederim ellerinize sağlık.
Ancak çok uzun sürdüğünden
D65536'yı D400 olarak
A65536'yı A400 olarak değiştirdim yine de çok uzun 5-10 dakika gibi sürüyor.
daha hızlı olması için birşey yapılabilir mi?

 

[Korhan Ayhan]

Selamlar,

Kodun hızlı çalışması için makro başlangıcında hesaplamayı manuele alabilirsiniz. Kodun çalışması bitince tekrar eski haline alırsak tüm hesaplamalar yapılarak işlem sonlandırılır.

Aşağıdaki yöntemi uygulayın.

Option Explicit
 
Sub MAKRO()
    Application.Calculation = xlCalculationManual
    'Kodlarınız
    Application.Calculation = xlCalculationAutomatic
End Sub

 

[Ergün Güler]

Çok teşekkürler sayın Korhan Ayhan.
D65536'yı D400 olarak
A65536'yı A400 olarak değiştirmem de bir sakınca yok öyle değil mi?
İyi çalışmalar.

 

[Korhan Ayhan]

Selamlar,

Neden olsunki. Dilediğiniz gibi ayarlayabilirsiniz.

 

[Ergün Güler]

Çok teşekkürler.