Zellenhöhe bei verbundenen Zellen (VBA Code?)

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Benutzer

Hi.
Probier mal den Code:

' Autofit von verbundenen Zellen
Public Sub instantFitHeight()
Dim tempWidth As Double
Dim zeLLe As Range
Dim totalWidth As Double
Dim totalPxWidth As Double
Dim myCells As Range
Dim tempHeight As Double
Dim oldHeight As Double
'    Dim adjWidth As Double
'    Dim i As Long
Application.ScreenUpdating = False
On Error GoTo fitErr
Set myCells = Selection
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 = _
.Cells(1).ColumnWidth + (.Cells(1).ColumnWidth - .Cells(2).ColumnWidth) / _
(.Cells(1).Width - .Cells(2).Width) * (totalPxWidth - .Cells(1).Width)
'    ' Breitenkorrektur, bis Breite in Pixel stimmt
'            adjWidth = .Cells(1).ColumnWidth
'            i = 1
'            While .Cells(1).Width  totalPxWidth
'                .Cells(1).ColumnWidth = adjWidth + i * 0.01
'                i = i + 1
'            Wend
' Führt Autofit durch
.EntireRow.AutoFit
' Speichert die Höhe zwischen
tempHeight = .RowHeight
' Weist der ersten zelle wieder die alte Breite zu
.Cells(1).ColumnWidth = tempWidth
' Verbindet die Zellen wieder
.MergeCells = True
' Weist Höhe zu (geht beim Verbinden wieder verloren)
.RowHeight = tempHeight + 0.75
End If
End With
On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub
fitErr:
On Error Resume Next
' Weist der ersten zelle wieder die alte Breite zu
myCells.Cells(1).ColumnWidth = tempWidth
' Verbindet die Zellen wieder
myCells.MergeCells = True
' Weist alte Höhe wieder zu
myCells.RowHeight = oldHeight
On Error GoTo 0
Application.ScreenUpdating = True
End Sub

Du mußt die Zelle markieren und den Code ausführen (über Shortcut oder Button). Ist aber nicht perfekt, ab und an macht er eine Zeile zu viel.
Gruss, Jogy

Beliebteste Forumthreads (12 Monate)

Zellenhöhe bei verbundenen Zellen (VBA Code?)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zellenhöhe bei verbundenen Zellen (VBA Code?)

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

306 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread