Excel'de Baskı Önizlemeye göre Satır Yüksekliği ayarlama

[akmlyx]

Değerli Üstatlar Merhaba, sorumu forumda araştırdım ancak baskı önizlemeye göre satır yüksekliğini ayarlama makrosu bulamadığım için yardımınıza ihtiyacım bulunmaktadır.
Sorum: Uzun bir listem var fakat kişilerin bilgileri burada görünmesin diye küçük bir örnek hazırlayarak ekte sundum. Ekteki Deneme isimli Excel çalışma kitabında da görüleceği üzere örneğin B3 hücresindeki metin baskı önizlemede tek satıra sığabiliyorken Excel bu metni iki satır gibi algıladığı için, fare ile toplu seçim yaparak çift tıkladığın zaman çift satır (40 piksel) yüksekliği ayarlıyor.
Benim istediğim yazılacak kodlar ile, hücrenin sütun genişliği sabit kalarak B3, C3, D3, E3, H3, I3, J3 ve K3 hücrelerindeki bütün metinler baskı önizlemede tek satır ise hücrenin satır yüksekliği 25 piksel olacak, yok eğer B3, C3, D3, E3, H3, I3, J3 ve K3 hücrelerindeki herhangi bir metin en fazla çift satır ise hücrenin yüksekliğini 42 piksel olacak, yine aynı hücrelerdeki metinlerin herhangi biri 3 satır ise satır yüksekliğini 55 piksel olacak.
Kısaca Makro, Excel hücrenin sütun genişliğini değiştirmeden hücredeki metnin baskı önizlemesine bakacak ona göre metin bulunan tüm satırları topluca satır yüksekliği ayarı yapacak. Bu şekilde bir kod yazılabilir mi acaba? İlginize şimdiden teşekkür ederim.

 

[pitchoute]

Merhabalar, deneyip sonucu paylaşabilir misiniz;

Sub SatirYuksekliginiAyarlama()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sayfa1")
    Dim sonSatir As Long
    sonSatir = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Dim sutunlar As Variant
    sutunlar = Array("B", "C", "D", "E", "H", "I", "J", "K")
    Dim i As Long, j As Long
    Dim maxSatirSayisi As Long
    Dim satirYuksekligi As Double
    Application.ScreenUpdating = False
    For i = 3 To sonSatir
        maxSatirSayisi = 1
        For j = LBound(sutunlar) To UBound(sutunlar)
            Dim hucre As Range
            Set hucre = ws.Cells(i, sutunlar(j))
            If Not IsEmpty(hucre.Value) Then
                Dim satirSayisi As Long
                satirSayisi = MetinSatirSayisiniHesapla(hucre)
                If satirSayisi > maxSatirSayisi Then
                    maxSatirSayisi = satirSayisi
                End If
            End If
        Next j
        Select Case maxSatirSayisi
            Case 1
                satirYuksekligi = 25
            Case 2
                satirYuksekligi = 42
            Case Is >= 3
                satirYuksekligi = 55
        End Select
        ws.Rows(i).RowHeight = satirYuksekligi
    Next i
    Application.ScreenUpdating = True
    MsgBox "Satır yükseklikleri başarıyla ayarlandı.", vbInformation
End Sub

Function MetinSatirSayisiniHesapla(hucre As Range) As Long

    Dim genislik As Double
    Dim yukseklik As Double
    Dim metin As String
    metin = hucre.Value
    If metin = "" Then
        MetinSatirSayisiniHesapla = 1
        Exit Function
    End If

    With hucre
        genislik = .ColumnWidth * 7
        Dim txtBox As Object
        Set txtBox = ThisWorkbook.Sheets(1).Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, genislik, 0)
        txtBox.TextFrame.Characters.Text = metin
        txtBox.TextFrame.Characters.Font.Name = .Font.Name
        txtBox.TextFrame.Characters.Font.Size = .Font.Size
        txtBox.TextFrame.AutoSize = True
        yukseklik = txtBox.Height
        txtBox.Delete
    End With
    Dim satirYuksekligi As Double
    satirYuksekligi = hucre.RowHeight
    MetinSatirSayisiniHesapla = Application.WorksheetFunction.RoundUp(yukseklik / satirYuksekligi, 0)
End Function

 

[akmlyx]

pitchoute hocam merhaba, öncelikle sorunumla ilgilendiğiniz için çok teşekkür ederim, ancak maalesef olmuyor.

 

[pitchoute]

Karşılaştığınız bir sorun ya da eksik olan kısımlar var mı? Belirtebilirseniz kodu revize edebilirim

 

[akmlyx]

pitchoute hocam, yazdığınız kodu gerçek Excel kitabında bir butona atayarak tıkladığım zaman ilk önce satırları genişletiyor, sonra tekrar ikinci tıklamamda bu sefer birçok satırları istenildiği satır sayısına bağlı olarak daraltıyor ancak, örneğin C23 hücresindeki metin tek satır olmasına karşın çift satır gibi satır yüksekliğini geniş veriyor, yine aynı şekilde I32, H33, B34, B40 hücrelerinde tek satırlı metinler(baskı önizlemede) olmasına rağmen çift satırlı metin varmış gibi yüksekliği fazla ayarlıyor.

 

[pitchoute]

Hocam şu şekilde dener misiniz;

Sub SatirYuksekliginiAyarlama()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sayfa1")
    Dim sonSatir As Long
    sonSatir = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Dim sutunlar As Variant
    sutunlar = Array("B", "C", "D", "E", "H", "I", "J", "K")
    Dim i As Long, j As Long
    Dim maxSatirSayisi As Long
    Dim satirYuksekligi As Double
    Application.ScreenUpdating = False
    Dim perLineHeight As Double
    With ws.Range("A1")
        .Value = "A"
        .Font.Name = ws.Cells(3, "B").Font.Name
        .Font.Size = ws.Cells(3, "B").Font.Size
        .WrapText = True
        .EntireRow.AutoFit
        perLineHeight = .RowHeight
        .Value = ""
        .WrapText = False
    End With
    For i = 3 To sonSatir
        maxSatirSayisi = 1
        For j = LBound(sutunlar) To UBound(sutunlar)
            Dim hucre As Range
            Set hucre = ws.Cells(i, sutunlar(j))
            If Not IsEmpty(hucre.Value) Then
                Dim satirSayisi As Long
                satirSayisi = MetinSatirSayisiniHesapla(hucre, perLineHeight)
                If satirSayisi > maxSatirSayisi Then
                    maxSatirSayisi = satirSayisi
                End If
            End If
        Next j
        satirYuksekligi = perLineHeight * maxSatirSayisi
        ws.Rows(i).RowHeight = satirYuksekligi
    Next i
    Application.ScreenUpdating = True
    MsgBox "Satır yükseklikleri başarıyla ayarlandı.", vbInformation
End Sub

Function MetinSatirSayisiniHesapla(hucre As Range, perLineHeight As Double) As Long
    Dim genislik As Double
    Dim yukseklik As Double
    Dim metin As String
    Dim ws As Worksheet
    Set ws = hucre.Worksheet
    metin = hucre.Value
    If metin = "" Then
        MetinSatirSayisiniHesapla = 1
        Exit Function
    End If

    With hucre
        genislik = .Width
        Dim txtBox As Shape
        Set txtBox = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, genislik, 1)
        txtBox.Line.Visible = msoFalse
        txtBox.Fill.Visible = msoFalse
        txtBox.TextFrame2.TextRange.Text = metin
        txtBox.TextFrame2.TextRange.Font.Name = .Font.Name
        txtBox.TextFrame2.TextRange.Font.Size = .Font.Size
        txtBox.TextFrame2.WordWrap = msoTrue
        txtBox.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
        yukseklik = txtBox.Height
        txtBox.Delete
    End With

    MetinSatirSayisiniHesapla = Application.WorksheetFunction.RoundUp(yukseklik / perLineHeight, 0)
End Function

 

[akmlyx]

Hocam bu hiç olmadı. Satırların yüksekliğini alakasız şekilde yükseltiyor.

 

[pitchoute]

Tekrardan merhaba, şöyle dener misiniz;

Sub SatirYuksekliginiAyarlama()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sayfa1")
    Dim sonSatir As Long
    sonSatir = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    Dim sutunlar As Variant
    sutunlar = Array("B", "C", "D", "E", "H", "I", "J", "K")
    Dim i As Long, j As Long
    Dim maxSatirSayisi As Long
    Dim satirYuksekligi As Double
    Application.ScreenUpdating = False
    For i = 3 To sonSatir
        maxSatirSayisi = 1
        For j = LBound(sutunlar) To UBound(sutunlar)
            Dim hucre As Range
            Set hucre = ws.Cells(i, sutunlar(j))
            If Not IsEmpty(hucre.Value) Then
                Dim satirSayisi As Long
                satirSayisi = GetLineCount(hucre)
                If satirSayisi > maxSatirSayisi Then
                    maxSatirSayisi = satirSayisi
                End If
            End If
        Next j
        Select Case maxSatirSayisi
            Case 1
                satirYuksekligi = 25
            Case 2
                satirYuksekligi = 42
            Case Is >= 3
                satirYuksekligi = 55
        End Select
        ws.Rows(i).RowHeight = satirYuksekligi
    Next i
    Application.ScreenUpdating = True
    MsgBox "Satır yükseklikleri başarıyla ayarlandı.", vbInformation
End Sub

Function GetLineCount(hucre As Range) As Long
    Dim metin As String
    Dim font As font
    Dim genislik As Double
    Dim toplamGenislik As Double
    Dim karakter As Variant
    metin = hucre.Value
    Set font = hucre.Font
    If metin = "" Then
        GetLineCount = 1
        Exit Function
    End If
    genislik = hucre.Width
    Dim metinGenisligi As Double
    metinGenisligi = GetTextWidth(metin, font)
    Dim satirSayisi As Long
    satirSayisi = Application.Ceiling(metinGenisligi / genislik, 1)
    GetLineCount = satirSayisi
End Function

Function GetTextWidth(metin As String, font As font) As Double
    Dim tempWS As Worksheet
    Dim tempChart As Chart
    Dim txtWidth As Double
    Set tempWS = ThisWorkbook.Sheets.Add
    Set tempChart = tempWS.ChartObjects.Add(Left:=1, Top:=1, Width:=1, Height:=1).Chart
    With tempChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 0, 0)
        .TextFrame2.TextRange.Characters.Text = metin
        .TextFrame2.TextRange.Font.Name = font.Name
        .TextFrame2.TextRange.Font.Size = font.Size
        txtWidth = .Width
        .Delete
    End With
    Application.DisplayAlerts = False
    tempWS.Delete
    Application.DisplayAlerts = True
    GetTextWidth = txtWidth
End Function