Zeilenhöhe automatisch anpassen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilenhöhe automatisch anpassen

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread