automatische Zeilenhöhe bei verbundenen Zellen
05.04.2006 04:02:20
Friedemann
Ich habe wieder mal ein Problem als nicht VBA Experte.
Ich möchte meine Zeilenhöhe von verbundenen Zellen automatisch anpassen.
Ich habe folgendes Makro gefunden welches auch sehr gut funktioniert. Ich möchte es aber wie folgt abändern:
1. Das Makro soll laufen wenn das Arbeitsblatt aufgerufen wird oder als Module über das Drücken einer Taste im Arbeitsblatt.
2. Das Makro soll die Zeilenhöhe für die Zellen e27:k112 (e-k ist verbunden, also Zeilen 27 bis 112) anpassen. (Range("e27:k112").Select ?)
Kann mir da jemand helfen?
Hier das Makro wie es zur Zeit ist:
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 + 15
.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
Vielen Dank an Alle
Friedemann