AW: Zeilenhöhe automatisch an Text anpassen
16.09.2010 14:13:36
JogyB
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