Birleştirilmiş Hücrede En Uygun Satır Yüksekliği Ayarlama

[ilkerinside]

Merhaba arkadaşlar. Makro kodu ile "Birleştirilmiş Hücrede En Uygun Satır Yüksekliği Ayarlama" sını gerçekleştiremedim. Bu konuda yardımcı olabilir misiniz !!

Ekte verdiğim çalışma programında tablo içerisinde C ile H arasındaki satırlara yazdığım metinin satır yüksekliğinin otomatik ayarlanmasını yapamadım. Bunu yapabilecek arkadaşlardan acil yardım bekliyorum. Yardımcı olacaklara şimdiden teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Dosyanızdaki tüm modülleri ve kodları silip aşağıdaki kodu "Sayfa1" isimli sayfanızın kod bölümüne uygulayın.

Sayfa1 'in kod bölümüne ulaşmak için;
Sayfa1 yazan yerde sağ klik yapın ve "kod görüntüle" seçeneğini seçin.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, GENİŞLİK As Integer, YÜKSEKLİK As Integer
    Dim VERİ As Variant, Satır As Integer, X As Integer
 
    If Intersect(Target, Range("E7:H" & Rows.Count)) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    GENİŞLİK = Range("E1:H1").Columns.Width
 
    Set S1 = Sheets("Sayfa2")
    Satır = 2
 
    Application.DisplayAlerts = False
 
    With S1
        .Cells.Delete
        .Cells.Font.Size = Target.Font.Size
        .Range("A1") = Target.Text
        .Range("A:A").WrapText = True
        .Range("A1").VerticalAlignment = xlJustify
        .Range("A1").ColumnWidth = GENİŞLİK / 5.3
        .Range("A1").EntireRow.AutoFit
 
        VERİ = Split(.Range("A1"), Chr(10))
 
        For X = 0 To UBound(VERİ)
            .Cells(Satır, 1) = VERİ(X)
            YÜKSEKLİK = YÜKSEKLİK + .Cells(Satır, 1).RowHeight
            Satır = Satır + 1
        Next
 
        .Cells.Delete
    End With
 
    Target.RowHeight = YÜKSEKLİK
    Set S1 = Nothing
 
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[ilkerinside]

teşekkürler Söylediğiniz şekilde yaptım yalnız hücre birleştirince özellik yine çalışmıyor normal hücrelerde çalıştı ama benim için tablo içinde birleştirilmiş hücrede çalışması yapılabilir mi yardımcı olursanız sevinirim

 

[Korhan Ayhan]

Merhaba,

Önerdiğim kod daha önce birleştirilmiş bir hücreye gireceğiniz veri uzunluğuna göre ilgili satırların satır yüksekliğini otomatik olarak ayarlar.

Sayfa olaylarında hücre birleştirme işlemi algılanmadığı için sizin istediğiniz şekilde çalışmaz. Çalışması için hücreleri birleştirilmiş hücre içine F2 ile ya da çift tıklayarak girip çıkmanız yeterli olacaktır. Böylece kod yeniden tetiklenmiş olacaktır.

 

[denese]

Merhaba,

Dosyanızdaki tüm modülleri ve kodları silip aşağıdaki kodu "Sayfa1" isimli sayfanızın kod bölümüne uygulayın.

Sayfa1 'in kod bölümüne ulaşmak için;
Sayfa1 yazan yerde sağ klik yapın ve "kod görüntüle" seçeneğini seçin.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, GENİŞLİK As Integer, YÜKSEKLİK As Integer
    Dim VERİ As Variant, Satır As Integer, X As Integer
 
    If Intersect(Target, Range("E7:H" & Rows.Count)) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    GENİŞLİK = Range("E1:H1").Columns.Width
 
    Set S1 = Sheets("Sayfa2")
    Satır = 2
 
    Application.DisplayAlerts = False
 
    With S1
        .Cells.Delete
        .Cells.Font.Size = Target.Font.Size
        .Range("A1") = Target.Text
        .Range("A:A").WrapText = True
        .Range("A1").VerticalAlignment = xlJustify
        .Range("A1").ColumnWidth = GENİŞLİK / 5.3
        .Range("A1").EntireRow.AutoFit
 
        VERİ = Split(.Range("A1"), Chr(10))
 
        For X = 0 To UBound(VERİ)
            .Cells(Satır, 1) = VERİ(X)
            YÜKSEKLİK = YÜKSEKLİK + .Cells(Satır, 1).RowHeight
            Satır = Satır + 1
        Next
 
        .Cells.Delete
    End With
 
    Target.RowHeight = YÜKSEKLİK
    Set S1 = Nothing
 
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Korhan Bey merhaba, öncelikle emeğinize sağlık tam olarak aradığım kod buydu. Ufak bir kriter eklemek istiyorum. Kod, en düşük satır yüksekliğini otomatik ayarlıyor, bense bunu 16 yaparak tanımlamak istiyorum. Yardımcı olabilir misiniz.

Saygılar

 

[denese]

Bir de şunu fark ettim; kod, boş bir hücreye F2 ile ya da çift tıklayarak girip çıkmanızda o satırı gizliyor. Bu konuda da yardımcı olabilir misiniz.

 

[denese]

Korhan Bey merhaba, öncelikle emeğinize sağlık tam olarak aradığım kod buydu. Ufak bir kriter eklemek istiyorum. Kod, en düşük satır yüksekliğini otomatik ayarlıyor, bense bunu 16 yaparak tanımlamak istiyorum. Yardımcı olabilir misiniz.

Saygılar

Bir de şunu fark ettim; kod, boş bir hücreye F2 ile ya da çift tıklayarak girip çıkmanızda o satırı gizliyor. Bu konuda da yardımcı olabilir misiniz.

Bu iki konuda yardımcı olabilecek arkadaşlardan destek rica ediyorum.

 

[denese]

Merhaba,

Dosyanızdaki tüm modülleri ve kodları silip aşağıdaki kodu "Sayfa1" isimli sayfanızın kod bölümüne uygulayın.

Sayfa1 'in kod bölümüne ulaşmak için;
Sayfa1 yazan yerde sağ klik yapın ve "kod görüntüle" seçeneğini seçin.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, GENİŞLİK As Integer, YÜKSEKLİK As Integer
    Dim VERİ As Variant, Satır As Integer, X As Integer
 
    If Intersect(Target, Range("E7:H" & Rows.Count)) Is Nothing Then Exit Sub
 
    Application.ScreenUpdating = False
    GENİŞLİK = Range("E1:H1").Columns.Width
 
    Set S1 = Sheets("Sayfa2")
    Satır = 2
 
    Application.DisplayAlerts = False
 
    With S1
        .Cells.Delete
        .Cells.Font.Size = Target.Font.Size
        .Range("A1") = Target.Text
        .Range("A:A").WrapText = True
        .Range("A1").VerticalAlignment = xlJustify
        .Range("A1").ColumnWidth = GENİŞLİK / 5.3
        .Range("A1").EntireRow.AutoFit
 
        VERİ = Split(.Range("A1"), Chr(10))
 
        For X = 0 To UBound(VERİ)
            .Cells(Satır, 1) = VERİ(X)
            YÜKSEKLİK = YÜKSEKLİK + .Cells(Satır, 1).RowHeight
            Satır = Satır + 1
        Next
 
        .Cells.Delete
    End With
 
    Target.RowHeight = YÜKSEKLİK
    Set S1 = Nothing
 
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Merhaba Sayın Korhan Ayhan,

Bu çalışmayı kendi çalışmama uyarladım, fakat aşağıda belirttiğim konularda da değerli destek ve görüşlerinize ihtiyaç duyuyorum.

1 - Kod, E7:H aralığında birleştirilen hücrelerin bulunduğu satır yüksekliğini otomatik genişletiyor. Benim istediğim ise, sadece bu aralıkta birleştirilen hücrelerin bulunduğu satır yüksekliğini değil, çalışma sayfasında herhangi bir aralıktaki birleştirilmiş hücrelerin bulunduğu satır yüksekliği için de aynı sonucu almak.
2 - Kod, boş bir hücreye F2 ile ya da çift tıklayarak girip çıkmanızda, veyahut delete yaptığımızda o satırı gizliyor.
3 - Kod, en düşük satır yüksekliğini otomatik ayarlıyor, bense bunu kod ile tanımlayabilmek istiyorum.

Örnek dosya ekte ve burada yer alıyor.

Yardımlarınız için sonsuz teşekkürler