Zeilenhöhe automatisch an Text anpassen

Henning · 1970-01-01T00:00:00+00:00

Hallo Experten, ich habe schon lange recherchiert und probiert, leider komm ich nicht zum gewünschten Ergebnis. Ich möchte in der Zeile 24, wo ein variabler Text drin steht automatisch dahingehend anpassen, das der Inhalt lesbar ist (Höhe der Zeile). Dies soll automatisch passieren und kann in ein bereits in der Datei vorhandenes Makro zur Erstellung des Inhaltes eingebaut werden. Vielen Dank für Eure Hilfe. P.S. folgender Code funktioniert nicht: ... Rows("24:24").Select Rows("24:24").EntireRow.AutoFit ...

Hallo Henning,
wie gesagt, das wirkt nur für verbundene Zellen... versuch das mal, im Test hat das bei mir funktioniert. Es darf nur eine Zeile angegeben/markiert sein.

Sub fitHeightComplete(Optional myRow As Range)
Dim sPalte As Long
Dim tempHeight As Double
If myRow Is Nothing Then
Set myRow = Selection.EntireRow
Else
Set myRow = Selection.EntireRow
End If
' Geht nur für einzelne Zeile
If myRow.Rows.Count > 1 Or myRow.Areas.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
' AutoFit-Höhe ohne die verbundenen Zellen
myRow.AutoFit
tempHeight = myRow.Height
' Und jetzt noch auslesen für alle verbundenen Zellen
With myRow
For sPalte = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
With .Cells(1, sPalte)
If .MergeCells Then
tempHeight = Application.Max(tempHeight, FitMergeHeight(.MergeArea))
sPalte = sPalte + .MergeArea.Columns.Count - 1
End If
End With
Next
' Zeilenhöhe auf erhaltenen Maximalwert
.RowHeight = tempHeight
End With
Application.ScreenUpdating = True
End Sub
' Autofit von verbundenen Zellen
Public Function FitMergeHeight(myCells As Range) As Double
Dim tempWidth As Double
Dim zeLLe As Range
Dim totalWidth As Double
Dim totalPxWidth As Double
Dim tempHeight As Double
Dim oldHeight As Double
On Error GoTo fitErr
With myCells
' Macht nur etwas für einzelne Zeile, wenn die Zellen verbunden sind und wenn der  _
Zeilenumbruch aktiv ist
If .Rows.Count = 1 And .MergeCells = True And (.WrapText = True Or IsNull(.WrapText))  _
Then
' Speichert alte Zeilehöhe zwischen
oldHeight = .RowHeight
' Speichert die Breite der ersten Zelle zwischen
tempWidth = .Cells(1).ColumnWidth
' Berechnet die Gesamtbreite der verbundenen Zellen
For Each zeLLe In myCells
totalWidth = zeLLe.ColumnWidth + totalWidth
totalPxWidth = zeLLe.Width + totalPxWidth
Next
' Löst den Verbund auf
.MergeCells = False
' weist der ersten Zelle (dort steht der Text) die Gesamtbreite zu
.Cells(1).ColumnWidth = totalWidth
' Breitenkorrektur auf Breite in Pixel
.Cells(1).ColumnWidth = Application.Min(255, _
.Cells(1).ColumnWidth + (.Cells(1).ColumnWidth - .Cells(2).ColumnWidth) / _
(.Cells(1).Width - .Cells(2).Width) * (totalPxWidth - .Cells(1).Width))
' Führt Autofit durch
.EntireRow.AutoFit
' Übergabewert
FitHeight = .RowHeight
' Weist der ersten zelle wieder die alte Breite zu
.Cells(1).ColumnWidth = tempWidth
' Verbindet die Zellen wieder
.MergeCells = True
End If
End With
On Error GoTo 0
Exit Function
endOnError:
On Error Resume Next
With myCells
' Weist der ersten zelle wieder die alte Breite zu
.Cells(1).ColumnWidth = tempWidth
' Verbindet die Zellen wieder
.MergeCells = True
' Weist alte Höhe wieder zu
.RowHeight = oldHeight
End With
FitHeight = 0
Exit Function
fitErr:
' Unschön, aber einfach, Fehlerbehandlung muss beendet werden
Resume endOnError
End Function

Aufgerufen wird das obere Sub.
Gruß, Jogy

Der Vollständigkeit halber hier noch eine Fehlerkorrektur:

Sub fitHeightComplete(Optional myRow As Range)
Dim sPalte As Long
Dim tempHeight As Double
If myRow Is Nothing Then
Set myRow = Selection.EntireRow
Else
Set myRow = myRow.EntireRow
End If
' Geht nur für einzelne Zeile
If myRow.Rows.Count > 1 Or myRow.Areas.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
' AutoFit-Höhe ohne die verbundenen Zellen
myRow.AutoFit
tempHeight = myRow.Height
' Und jetzt noch auslesen für alle verbundenen Zellen
With myRow
For sPalte = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
With .Cells(1, sPalte)
If .MergeCells Then
tempHeight = Application.Max(tempHeight, FitMergeHeight(.MergeArea))
sPalte = sPalte + .MergeArea.Columns.Count - 1
End If
End With
Next
' Zeilenhöhe auf erhaltenen Maximalwert
.RowHeight = tempHeight
End With
Application.ScreenUpdating = True
End Sub
' Autofit von verbundenen Zellen
Public Function FitMergeHeight(myCells As Range) As Double
Dim tempWidth As Double
Dim zeLLe As Range
Dim totalWidth As Double
Dim totalPxWidth As Double
Dim tempHeight As Double
Dim oldHeight As Double
On Error GoTo fitErr
With myCells
' Macht nur etwas für einzelne Zeile, wenn die Zellen verbunden sind und wenn der  _
Zeilenumbruch aktiv ist
If .Rows.Count = 1 And .MergeCells = True And (.WrapText = True Or IsNull(.WrapText))  _
Then
' Speichert alte Zeilehöhe zwischen
oldHeight = .RowHeight
' Speichert die Breite der ersten Zelle zwischen
tempWidth = .Cells(1).ColumnWidth
' Berechnet die Gesamtbreite der verbundenen Zellen
For Each zeLLe In myCells
totalWidth = zeLLe.ColumnWidth + totalWidth
totalPxWidth = zeLLe.Width + totalPxWidth
Next
' Löst den Verbund auf
.MergeCells = False
' weist der ersten Zelle (dort steht der Text) die Gesamtbreite zu
.Cells(1).ColumnWidth = totalWidth
' Breitenkorrektur auf Breite in Pixel
.Cells(1).ColumnWidth = Application.Min(255, _
.Cells(1).ColumnWidth + (.Cells(1).ColumnWidth - .Cells(2).ColumnWidth) / _
(.Cells(1).Width - .Cells(2).Width) * (totalPxWidth - .Cells(1).Width))
' Führt Autofit durch
.EntireRow.AutoFit
' Übergabewert
FitHeight = .RowHeight
' Weist der ersten zelle wieder die alte Breite zu
.Cells(1).ColumnWidth = tempWidth
' Verbindet die Zellen wieder
.MergeCells = True
End If
End With
On Error GoTo 0
Exit Function
endOnError:
On Error Resume Next
With myCells
' Weist der ersten zelle wieder die alte Breite zu
.Cells(1).ColumnWidth = tempWidth
' Verbindet die Zellen wieder
.MergeCells = True
' Weist alte Höhe wieder zu
.RowHeight = oldHeight
End With
FitHeight = 0
Exit Function
fitErr:
' Unschön, aber einfach, Fehlerbehandlung muss beendet werden
Resume endOnError
End Function

Betrifft das zweite Set myRow = ... in der ersten If-Abfrage.
Gruß, Jogy

Zeilenhöhe automatisch an Text anpassen

Forumthread: Zeilenhöhe automatisch an Text anpassen

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial