AW: Zeilenhöhe automatisch anpassen
23.02.2005 04:07:57
Michael
Hi ... das ist standardmäßig für verbundene Zellen nicht implementiert ...
Mit folgender VBA-Funktion sollte es aber gehen (hatte sie ursprünglich mal irgendwo hier gefunden ...)
Diese muss allerdings erst ins VBA-Fenster (+, dann Eintrag "Diese Arbeitsmappe" im Projektfenster anklicken und ins Codefenster einfügen) kopiert werden. Dann ist Sie über + aufrufbar.
Funktioniert, wenn die verbundene Zelle markiert ist (und die Zeilenumbrüche für die Zelle aktiviert sind) ...
-----------------------------------------------------------------------------------------
Sub autofitXLMergedCells()
'Passt Zeilenhöhe an den Text innerhalb von verbundenen Zellen im selektierten Bereich an
'(Die Autofit-Methode des Excel-Range-Objektes funktioniert für verbundene Zellen nicht)
On Error GoTo Err_autofitXLMergedCells
Dim lo_CurRange As Excel.Range
Dim lsg_SumCellWidths As Single
Dim lsg_OriginalWidthFirstCol As Single
Dim lsg_NewRowHeight As Single
Dim li_MergedCellsCount As Integer
With Selection
If .MergeCells Then
If .Rows.Count = 1 And .WrapText = True Then
lsg_OriginalWidthFirstCol = .Cells(, 1).ColumnWidth
'Einzelzellbreiten und Breiten der Gitterlinien summieren
For Each lo_CurRange In Selection
lsg_SumCellWidths = lo_CurRange.ColumnWidth + lsg_SumCellWidths
li_MergedCellsCount = li_MergedCellsCount + 1
Next
lsg_SumCellWidths = lsg_SumCellWidths + (li_MergedCellsCount - 1) * 0.71
'Verbindung der Zellen aufheben, erste (datentragende) Zelle auf Gesamtbreite ausdehnen und
'Höhe anpassen über Standardmethode
.MergeCells = False
.Cells(1).ColumnWidth = lsg_SumCellWidths
.EntireRow.AutoFit
'Resultierende Zeilenhöhe merken, erste Zelle zurücksetzen, Verbindung wiederherstellen, Höhe anpassen
lsg_NewRowHeight = .RowHeight
.Cells(1).ColumnWidth = lsg_OriginalWidthFirstCol
.MergeCells = True
.RowHeight = lsg_NewRowHeight
End If
End If
End With
Exit Sub
'Nur für's Debuggen
Resume
Err_autofitXLMergedCells:
MsgBox Err.Number & ": " & Err.Description
End Sub
------------------------------------------------------
Grüßle
Micha