• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Birleştirilmiş hücrede otomatik satır yüksekliği

S

sefaburan

Katılım
1 Kasım 2012
Mesajlar
275
Excel Vers. ve Dili
Microsoft Office 2013 Türkçe
Arkadaşlar ekteki dosyada şablon sayfasının a14 ile a15 şablon ilgi sayfasında da a13 a14 a15 a16. satırlarda uzun metin girildiğinde satır yüksekliği ona göre ayarlansın, kısa metin girildiğinde ona göre ayarlansın. yani bu satırlarda satır yüksekliği otomatik ayarlansın bu mümkün müdür.

İste Dosyam: http://s3.dosya.tc/server29/DHcJLK/ResmiYaz__.rar.html
 
Hücreye tıkladıkdan sonra yukarıdaki metni kaydır butonuna tıklayın. Sorun çözülür
 
Önce metni kaydır yapın. Sonra Biçim>En uygun satır yüksekliği yapınız.
 
Birleştirilmiş hücrelerde bu özellik kullanılmıyormuş.
 
evet hocam zaten problem birleştirilmiş hücre olması.
 
O zaman şöyle bir yöntem uygulayın.
Kullanmayacağınız bir sütunun 14. satırına örneğin CA14 sütununun sütun genişliğini A-AE arası sütun genişliğiyle aynı boyutta ayarlayın.
Sonra CA14 hücresine yukarıda belirttiğim yöntemi uygulayın. Ve CA14 sütununa =A14 yapın.
 
Muhammet Okumuş' Alıntı:
O zaman şöyle bir yöntem uygulayın.
Kullanmayacağınız bir sütunun 14. satırına örneğin CA14 sütununun sütun genişliğini A-AE arası sütun genişliğiyle aynı boyutta ayarlayın.
Sonra CA14 hücresine yukarıda belirttiğim yöntemi uygulayın. Ve CA14 sütununa =A14 yapın.
Genişletmek için tıkla ...


üstad bu kısmen işe yaradı fakat her seferinde aynı işlemi yapmak gerekiyor. yani sürekli metin kaydır/biçim-en uygun yükseklik yapmak gerekiyor
 
Sub Satır_Yükseklik()
Range("A14").RowHeight = 15
Range("CA14").WrapText = False
Range("CA14") = Range("A14").Value
Range("CA14").WrapText = True
Range("CA14").Rows.AutoFit
End Sub
Genişletmek için tıkla ...
Bu kodu kullanın.
 
Muhammet Okumuş' Alıntı:
Bu kodu deneyin.
Genişletmek için tıkla ...

tamam hocam kodu şimdi daralt genişlet için yaptığımız kodların içine yapıştırdım. yazıyı yazdıkdan sonra daralt ya da genişlet butonuna basıyorum otomatik ikinisini de hallediyor. çok çok teşekkürler. bunları butonsuz yapamayız değil mi. yani butona basmadan kendiliğinden olmuyor
 
Kodu şablon sayfasının kod bölümüne kopyalayın.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Range("A14"), Target) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Range("A14").RowHeight = 15
Range("CA14").WrapText = False
Range("CA14") = Range("A14").Value
Range("CA14").WrapText = True
Range("CA14").Rows.AutoFit
b = 3
10
sat = Cells(Rows.Count, 1).End(3).Row
x = 797.25
a = Range("A1:A" & sat).Rows.Height

If a > x Then
If WorksheetFunction.CountA(Range("A" & sat - b & ":M" & sat - b)) = 0 Then
Rows(sat - b).Delete
Else
b = b + 1
GoTo 10
End If
GoTo 10
End If

20
sat = Cells(Rows.Count, 1).End(3).Row
x = 782
a = Range("A1:A" & sat).Rows.Height
If a < x Then
Rows(sat - 2).Insert
GoTo 20
End If


End Sub
Genişletmek için tıkla ...
 
Muhammet Okumuş' Alıntı:
Kodu şablon sayfasının kod bölümüne kopyalayın.
Genişletmek için tıkla ...

hocam hücrelerde biraz değişiklik yaptım. ben otomatik genişlik kodlarını 14. 15. ve 16. satır için uyarladım. orjinal çalışma kitabıma uydurdum, güzel de çalışıyordu önceki kodlar da. bu son verdiğiniz koda uyarladığımda sıkıntı oldu kod çalışmadı.


Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Range("A14"), Target) Is Nothing Then Exit Sub
If Intersect(Range("A16"), Target) Is Nothing Then Exit Sub
If Intersect(Range("A16"), Target) Is Nothing Then Exit Sub

Application.ScreenUpdating = False
Range("BS14").WrapText = False
Range("BS14") = Range("A14").Value
Range("BS14").WrapText = True

Range("BS15").WrapText = False
Range("BS15") = Range("A15").Value
Range("BS15").WrapText = True

Range("BS16").WrapText = False
Range("BS16") = Range("A16").Value
Range("BS16").WrapText = True

b = 3
10
sat = Cells(Rows.Count, 1).End(3).Row
x = 797.25
a = Range("A1:A" & sat).Rows.Height

If a > x Then
If WorksheetFunction.CountA(Range("A" & sat - b & ":M" & sat - b)) = 0 Then
Rows(sat - b).Delete
Else
b = b + 1
GoTo 10
End If
GoTo 10
End If

20
sat = Cells(Rows.Count, 1).End(3).Row
x = 782
a = Range("A1:A" & sat).Rows.Height
If a < x Then
Rows(sat - 2).Insert
GoTo 20
End If

End Sub

bu kodu her üç satır için de bu şekilde kullanmaya çalıştım fakat hata aldım. b=3 satırının altındaki 10 satırında hata uyarısı veriyor.
 
Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Range("A14:A16"), Target) Is Nothing Then Exit Sub


Application.ScreenUpdating = False
Range("BS14").WrapText = False
Range("BS14") = Range("A14").Value
Range("BS14").WrapText = True
Range("BS14").Rows.AutoFit

Range("BS15").WrapText = False
Range("BS15") = Range("A15").Value
Range("BS15").WrapText = True
Range("BS15").Rows.AutoFit

Range("BS16").WrapText = False
Range("BS16") = Range("A16").Value
Range("BS16").WrapText = True
Range("BS16").Rows.AutoFit
b = 3
10
sat = Cells(Rows.Count, 1).End(3).Row
x = 797.25
a = Range("A1:A" & sat).Rows.Height

If a > x Then
If WorksheetFunction.CountA(Range("A" & sat - b & ":M" & sat - b)) = 0 Then
Rows(sat - b).Delete
Else
b = b + 1
GoTo 10
End If
GoTo 10
End If

20
sat = Cells(Rows.Count, 1).End(3).Row
x = 782
a = Range("A1:A" & sat).Rows.Height
If a < x Then
Rows(sat - 2).Insert
GoTo 20
End If

End Sub
Genişletmek için tıkla ...
Kodu deneyiniz. A16 birleştirilmiş hücre olmadığından kodda değişiklik yapmak gerek. Veya A16:AE16 birleştirilmiş hücre yapınız.
 
Muhammet Okumuş' Alıntı:
Kodu deneyiniz. A16 birleştirilmiş hücre olmadığından kodda değişiklik yapmak gerek. Veya A16:AE16 birleştirilmiş hücre yapınız.
Genişletmek için tıkla ...

yok hocam gerek yok bu duruma. bazen alt kurum eklemek gerekiyor. dolayısıyla 11. satıra alt kurum ekle butonu ile satır ekliyorum bu durumda satırlar birer tane kaymış oluyor onun için gerekli. ALLAH razı olsun çok güzel oldu.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst