girilen metne göre hücrenin açılması ve daralması

[Yesilyurtlu]

Selamün Aleyküm;
Değerli üstadlarım A13:J13 arasındaki hücrem birleştirilmiş hücre. Bu hücreye gireceğim metinin karakter sayısına bağlı kalmaksızın yukarıda belirttiğim birleştirilmiş hücre dikey olarak yazı tam okunacak şekilde genişleyebilir mi?
Bu konu için yardımcı olabilir misiniz? Teşekkür Ederim

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz. Sarı renkli hücreye veri girip deneyiniz.


Uygulanan kod; (Sayfanın kod bölümüne uygulayınız.)

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim GENİŞLİK As Integer, YÜKSEKLİK As Integer
    Dim VERİ As Variant, S1 As Worksheet, X As Integer, Satır As Long
    
    If Intersect(Target, Range("A13:J13")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    GENİŞLİK = Range("A13:J13").Columns.Width
    
    Set S1 = Sheets.Add
    Satır = 2
    
    Application.DisplayAlerts = False
    
    With S1
        .Cells.Font.Size = Target.Font.Size
        .Range("A1") = "=Sayfa1!A13"
        .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
        
        .Delete
    End With
    
    Target.RowHeight = YÜKSEKLİK
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[Yesilyurtlu]

Korhan Abi
İlkönce Mesajıma cevap verdiğiniz için teşekkür ederim.
İkinci olarak vallahi mesajınızı şimdi gördüm teşekkürümü geç ettim. Kusura bakmayın Hakkınızı helal edin. Bu kusurum içinde affımı rica ediyorum. Lütfen Kabul edin